Author Topic: Whats wrong with this Lisp? (Read 11108 times)

efernal · « **Reply #30 on:** March 24, 2010, 01:33:41 PM »

;;;   HI, I have some routines for this
;;;
;;;   See in
;;;
;;;   http://www.gr-acad.com.br/Pacote/ipontos.html
;;;   http://www.gr-acad.com.br/Pacote/azimute/azimute.html
;;;
;;;   and more in
;;;
;;;   http://www.gr-acad.com.br/pac.htm
;;;
;;;   e.fernal
;;;
;;;   Here is my version for your need...
;|
   please, adjust

   (LOAD_DIALOG
        (STRCAT gr-pack-usb-char-drive
           ":\\Gr-Pack-Usb\\Dlg\\DCL0110.dcl"
        )
        )

   according your paths...

and here is the necessary dcl file contents...

efpac0110:dialog{label="E.Fernal Software";key="efernal";width=54;fixed_width=true;initial_focus="numero";
:spacer{height=0.5;}
:text{label="Dados para pontos";alignment=centered;fixed_width_font=true;height=1.5;fixed_height=true;}
:column{alignment=centered;fixed_width=true;fixed_height=true;
:edit_box{label="Número inicial";key="numero";edit_width=12;edit_limit=6;}
:edit_box{label="Altura da fonte";key="hfonte";edit_width=12;edit_limit=5;}}
:spacer{height=0.5;}
:row{alignment=centered;fixed_width=true;fixed_height=true;
:button{label="Como &usar";key="help";mnemonic="u";width=15;height=2.5;fixed_width=true;fixed_height=true;alignment=top;}
:button{label="&Cancelar";key="cancel";is_cancel=true;mnemonic="C";width=15;height=2.5;
fixed_width=true;fixed_height=true;alignment=top;}
:button{label="&Prosseguir";key="accept";mnemonic="P";width=15;height=2.5;
fixed_width=true;fixed_height=true;alignment=top;}}}

|;

(DEFUN c:pts (/   pt arq sn cn dh   w@
     ;; setvars
     attreq attdia
     ;; parâmetros necessários
     numero hfonte
     ;; funçoes locais...
     exec ajuda verif make_block efernal_acet)
;; ################################################################ ;;
(DEFUN efernal_acet (s)
(IF   ACET-UI-MESSAGE
(ACET-UI-MESSAGE s "E.Fernal Software")
(ALERT s)
)
)
;; ################################################################ ;;
(DEFUN exec (/ arq file lista p1)
(SETQ arq (OPEN (STRCAT (GETVAR "TempPrefix") "EFPAC0110.TXT") "w"))
(WHILE (SETQ
     p1   (GETPOINT
        (STRCAT "\r-> Clique no ponto [ " (ITOA numero) " ] : ")
      )
     )
(ENTMAKE (LIST (CONS 0 "POINT") (CONS 10 p1)))
(ENTMAKE (LIST (CONS 0 "TEXT")
        (CONS 1 (ITOA numero))
        (CONS 10
           (LIST (+ (CAR p1) (* 2.0 hfonte))
             (- (CADR p1) (* 2.0 hfonte))
             (CADDR p1)
           )
        )
        (CONS 40 hfonte)
        (CONS 50 0.0)
        (CONS 71 0)
        (CONS 72 0)
        (CONS 73 0)
     )
)
(SETQ numero (1+ numero))
(IF (AND arq (= (TYPE arq) 'file))
   (PROGN (PRINC "(" arq)
     (PRINC (CHR 34) arq)
     (PRINC numero arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CAR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CADR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CADDR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC ")\n" arq)
   )
   nil
)
)
(IF   (AND arq (= (TYPE arq) 'file))
(CLOSE arq)
)
(SETQ arq nil)
;; ################################################################### ;;
(IF   (SETQ
     arq (FINDFILE (STRCAT (GETVAR "TempPrefix") "EFPAC0110.TXT"))
   )
(IF (SETQ   p1
       (GETPOINT "\n-> Ponto de inserção da tabela descritiva : ")
     )
   (IF (SETQ file (OPEN arq "r"))
     (PROGN (IF (NULL (TBLSEARCH "BLOCK" "EFPAC0110"))
        (make_block)
       )
       (SETQ attreq (GETVAR "ATTREQ")
        attdia (GETVAR "ATTDIA")
       )
       (SETVAR "ATTREQ" 1)
       (SETVAR "ATTDIA" 0)
       (COMMAND "._-INSERT" "EFPAC0110" "_NON"
           p1     hfonte     hfonte
           0.0     "PT. Número"
           "Leste" "Norte"     "Cota"
          )
       (SETQ p1
         (LIST (CAR p1) (- (CAR p1) (* 2.0 hfonte)) (CADDR p1))
       )
       (WHILE   (SETQ linha (READ-LINE file))
        (SETQ lista (READ linha))
        (IF (AND (= (TYPE lista) 'LIST) (= (LENGTH lista) 4))
        (PROGN (COMMAND "._-INSERT"
              "EFPAC0110"
              "_NON"
              p1
              hfonte
              hfonte
              0.0
              (CAR lista)
              (CADR lista)
              (CADDR lista)
              (CADDDR lista)
           )
           (SETQ p1 (LIST (CAR p1)
                 (- (CAR p1) (* 2.0 hfonte))
                 (CADDR p1)
              )
           )
        )
        nil
        )
       )
       (CLOSE file)
       (SETVAR "ATTREQ" attreq)
       (SETVAR "ATTDIA" attdia)
     )
     (efernal_acet
     (STRCAT
     "Erro:\n\n\t"
     "Não foi possível abrir o arquivo para leitura!\t\n\n"
     )
     )
   )
   (PRINC "\n-> Ponto de inserção não foi fornecido...")
)
(efernal_acet
   (STRCAT   "Erro:\n\n\t"
      "Não foi possível encontrar o arquivo\t\n\t"
      "com os dados dos pontos coletados...\t\n\n"
   )
)
)
)
;; ################################################################ ;;
(DEFUN verif ()
(IF   (AND (SETQ numero (GET_TILE "numero"))
     (NUMBERP (READ numero))
     (= (TYPE (READ numero)) 'int)
     (> (ATOI numero) 0)
     ;;
     (SETQ hfonte (GET_TILE "hfonte"))
     (NUMBERP (READ hfonte))
     (> (ATOF hfonte) 0.0)
     ;;
   )
(PROGN (SETQ numero (ATOI numero)
        hfonte (ATOF hfonte)
     )
     (DONE_DIALOG 1)
)
(efernal_acet
   (STRCAT
     "Erro:\n\n\t"
     "Verifique os campos\n\t"
     "\"Número inicial\" e \"Altura da fonte\".\t\n\t"
     "O número deve ser um número inteiro e\t\n\t"
     "maior que zero e a altura da fonte deve\t\n\t"
     "ser um número, inteiro ou real, maior que\t\n\t"
     "zero.\n\n\tTente novamente...\n\n"
    )
)
)
)
;; ################################################################ ;;
(DEFUN make_block ()
(IF   (NULL (TBLSEARCH "BLOCK" "EFPAC0110"))
(PROGN
   (IF (NULL (TBLSEARCH "STYLE" "Verdana"))
     (ENTMAKE '((0 . "STYLE")
        (100 . "AcDbSymbolTableRecord")
        (100 . "AcDbTextStyleTableRecord")
        (2 . "Verdana")
        (70 . 0)
        (40 . 0.0)
        (41 . 1.0)
        (50 . 0.0)
        (71 . 0)
        (42 . 1.0)
        (3 . "verdana.TTF")
        (4 . "")
        )
     )
   )
   (ENTMAKE
     '((0 . "BLOCK") (2 . "EFPAC0110") (70 . 2) (10 0.0 0.0 0.0))
   )
   (ENTMAKE '((0 . "LWPOLYLINE")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbPolyline")
        (90 . 4)
        (70 . 1)
        (43 . 0.0)
        (38 . 0.0)
        (39 . 0.0)
        (10 40.0 -2.0)
        (40 . 0.0)
        (41 . 0.0)
        (42 . 0.0)
        (91 . 0)
        (10 0.0 -2.0)
        (40 . 0.0)
        (41 . 0.0)
        (42 . 0.0)
        (91 . 0)
        (10 0.0 0.0)
        (40 . 0.0)
        (41 . 0.0)
        (42 . 0.0)
        (91 . 0)
        (10 40.0 0.0)
        (40 . 0.0)
        (41 . 0.0)
        (42 . 0.0)
        (91 . 0)
        (210 0.0 0.0 1.0)
        )
   )
   (ENTMAKE '((0 . "LINE")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbLine")
        (10 10.0 0.0 0.0)
        (11 10.0 -2.0 0.0)
        (210 0.0 0.0 1.0)
        )
   )
   (ENTMAKE '((0 . "LINE")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbLine")
        (10 20.0 0.0 0.0)
        (11 20.0 -2.0 0.0)
        (210 0.0 0.0 1.0)
        )
   )
   (ENTMAKE '((0 . "LINE")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbLine")
        (10 30.0 0.0 0.0)
        (11 30.0 -2.0 0.0)
        (210 0.0 0.0 1.0)
        )
   )
   (ENTMAKE '((0 . "ATTDEF")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbText")
        (10 1.0 -1.5 0.0)
        (40 . 1.0)
        (1 . "")
        (50 . 0.0)
        (41 . 1.0)
        (51 . 0.0)
        (7 . "Verdana")
        (71 . 0)
        (72 . 0)
        (11 0.0 0.0 0.0)
        (210 0.0 0.0 1.0)
        (100 . "AcDbAttributeDefinition")
        (280 . 0)
        (3 . "Número do ponto")
        (2 . "1")
        (70 . 0)
        (73 . 0)
        (74 . 0)
        (280 . 0)
        )
   )
   (ENTMAKE '((0 . "ATTDEF")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbText")
        (10 11.0 -1.5 0.0)
        (40 . 1.0)
        (1 . "")
        (50 . 0.0)
        (41 . 1.0)
        (51 . 0.0)
        (7 . "Verdana")
        (71 . 0)
        (72 . 0)
        (11 0.0 0.0 0.0)
        (210 0.0 0.0 1.0)
        (100 . "AcDbAttributeDefinition")
        (280 . 0)
        (3 . "Coordenada X")
        (2 . "2")
        (70 . 0)
        (73 . 0)
        (74 . 0)
        (280 . 0)
        )
   )
   (ENTMAKE '((0 . "ATTDEF")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbText")
        (10 21.0 -1.5 0.0)
        (40 . 1.0)
        (1 . "")
        (50 . 0.0)
        (41 . 1.0)
        (51 . 0.0)
        (7 . "Verdana")
        (71 . 0)
        (72 . 0)
        (11 0.0 0.0 0.0)
        (210 0.0 0.0 1.0)
        (100 . "AcDbAttributeDefinition")
        (280 . 0)
        (3 . "Coordenada Y")
        (2 . "3")
        (70 . 0)
        (73 . 0)
        (74 . 0)
        (280 . 0)
        )
   )
   (ENTMAKE '((0 . "ATTDEF")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbText")
        (10 31.0 -1.5 0.0)
        (40 . 1.0)
        (1 . "")
        (50 . 0.0)
        (41 . 1.0)
        (51 . 0.0)
        (7 . "Verdana")
        (71 . 0)
        (72 . 0)
        (11 0.0 0.0 0.0)
        (210 0.0 0.0 1.0)
        (100 . "AcDbAttributeDefinition")
        (280 . 0)
        (3 . "Coordenada Z")
        (2 . "4")
        (70 . 0)
        (73 . 0)
        (74 . 0)
        (280 . 0)
        )
   )
   (ENTMAKE '((0 . "ENDBLK")))
)
nil
)
)
;; ################################################################ ;;
(DEFUN ajuda ()
(efernal_acet
(STRCAT "Como usar:\n\n\t"
     "Esta rotina permite inserir dados em uma\t\n\t"
     "série de pontos clicados e, ao fim, gerar\t\n\t"
     "uma tabela descritiva destes pontos.\t\n\n"
)
)
)
;; ################################################################ ;;
(IF (> (SETQ dh (LOAD_DIALOG
        (STRCAT gr-pack-usb-char-drive
           ":\\Gr-Pack-Usb\\Dlg\\DCL0110.dcl"
        )
        )
    )
    0
)
(IF   (NEW_DIALOG "efpac0110" dh)
(PROGN (ACTION_TILE "accept" "(Verif)")
     (ACTION_TILE "cancel" "(DONE_DIALOG 0)")
     (ACTION_TILE "help" "(Ajuda)")
     (SETQ w@ (START_DIALOG))
     (UNLOAD_DIALOG dh)
     (COND ((= w@ 0) (PRINC "\n-> Cancelado..."))
        ((= w@ 1) (exec))
     )
)
nil
)
(efernal_acet
(STRCAT "Erro:\n\n\t"
     "Não foi possível carregar o arquivo DCL!\t\n\n"
)
)
)
(PRINC)
)

efernal · « **Reply #31 on:** March 24, 2010, 01:39:01 PM »

PLEASE, CORRECT

(SETQ p1 (LIST (CAR p1)
                 (- (CAR p1) (* 2.0 hfonte))
                 (CADDR p1)
              )
           )

TO

(SETQ p1 (LIST (CAR p1)
                 (- (CADR p1) (* 2.0 hfonte))
                 (CADDR p1)
              )
           )

e.fernal

efernal · « **Reply #32 on:** March 24, 2010, 01:42:49 PM »

ooops, not extensively tested...

correct

(SETQ numero (1+ numero))
(IF (AND arq (= (TYPE arq) 'file))
   (PROGN (PRINC "(" arq)
     (PRINC (CHR 34) arq)
     (PRINC numero arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CAR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CADR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CADDR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC ")\n" arq)
   )
   nil
)

to

(IF (AND arq (= (TYPE arq) 'file))
   (PROGN (PRINC "(" arq)
     (PRINC (CHR 34) arq)
     (PRINC numero arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CAR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CADR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CHR 32) arq)
     (PRINC (CHR 34) arq)
     (PRINC (CADDR p1) arq)
     (PRINC (CHR 34) arq)
     (PRINC ")\n" arq)
   )
   nil
)
(SETQ numero (1+ numero))

and sorry for not a king's english...

e.fernal

HasanCAD · « **Reply #33 on:** March 24, 2010, 08:49:02 PM »

efernal
Is there an english version of this website?

efernal · « **Reply #34 on:** March 24, 2010, 09:39:10 PM »

not yet...
will try to translate something...

e.fernal

HasanCAD · « **Reply #35 on:** March 25, 2010, 02:38:38 AM »

Quote from: efernal on March 24, 2010, 09:39:10 PM

not yet...
will try to translate something...

e.fernal

I think that It will better to start with the lisp name.

PS the lisp not working?

efernal · « **Reply #36 on:** March 25, 2010, 07:23:18 AM »

try it by yourself...
type POINTS to run...
e.fernal

News:

Author Topic: Whats wrong with this Lisp? (Read 11108 times)

efernal

Re: Whats wrong with this Lisp?

efernal

Re: Whats wrong with this Lisp?

efernal

Re: Whats wrong with this Lisp?

HasanCAD

Re: Whats wrong with this Lisp?

efernal

Re: Whats wrong with this Lisp?

HasanCAD

Re: Whats wrong with this Lisp?

efernal

Re: Whats wrong with this Lisp?