[编程交流] 更新旧LISP代码

;2002/05/21 - SURVEY.lsp
;this routine reads an ascii file with 5 elements in the order
;of - stn-pt (integer or real), y , x , z , note (string)
;and elevation from z value
;to run this routine you must have a block named in the variable PTDWG with 3
;attributes 
(setq REVVER "2")
;rev 2003/03/19 - fix block elev to zero - fix OSNAP problem
;rev 2002/10/04 - neg elevs, check for / or space after 1 letter FC
(setvar "cmdecho" 0)
(setq SNAPSET (menucmd "M=$(getvar,OSMODE)"))
;(print SNAPSET)
(print (strcat "SURVEY ROUTINE LOADED - rev" REVVER))
(defun C:SURVEY ( / F1)
   (command "OSMODE" 0)
;    (command "OSMODE" 16384)
   (setq PTDWG "x-el")
     (setq BLKDIR "j:/lib/lisp/blocks.txt")
;    (setq BLKDIR "c:/baw/blocks.txt")
   (print BLKDIR)
 (setq  FDIR  (getstring "\nENTER PATH (ie C:\\BAW ).."))
   (print (vl-directory-files FDIR "*.asc"))
 (setq  FFILE (getstring "\nENTER FILE NAME (no extension) .."))
 (setq  FNAME (strcat FDIR "/" FFILE ".asc"))
 (setq  BLKSCALE (/ (getreal "\ENTER PLOT SCALE (1:500 = 500)") 1000))
   (command "Layer" "M" FFILE "")
 (setq  F1 (open FNAME "r"))
      (while
         (setq PDATA (read-line F1))
   ;    (print pdata)
       ;(getstring "ReadLine")
        (DO-IT)
   );end of while
 (close F1)
(command "ZOOM" "e")
(print "OK")
(command "OSMODE" SNAPSET)
);end of points
 (defun do-it ( / pnt n m L P x y)
   ;  (print "DO-IT MODULE")(print PDATA)
   (setq
           COUNTER99 1
       n 1
           m 1
           pnt nil
       pnt2 nil
           DESC nil
       L (strlen pdata)
     );end of setq
      (while (< n (+ L 2))
        (setq x (substr pdata n 1))
;         (if (or (or (= x ",") (= x "")) (or (= x "/") (= x " ")))
        (if (or (= x ",") (= x ""))
          (progn
           (setq PNT
              (append PNT
              (list (atof (substr PDATA M (- N M))))
              );end of append
           );end of setq
           (setq PNT2
               (append PNT2
                (list (substr PDATA M (- N M)))
               );end of append
            );end of setq
          (setq ATT (vl-string-right-trim " " (last PNT2)))
       (setq DESC (vl-string-right-trim "+0" ATT))
(print DESC)
       (setq DESC (vl-string-right-trim "+1" DESC))
(print DESC)
       (setq DESC (vl-string-right-trim "+2" DESC))
(print DESC)
       (setq DESC (vl-string-right-trim "+3" DESC))
(print DESC)
;        (setq DESC (vl-string-right-trim "+0" ATT))
;        (setq DESC (vl-string-right-trim "+1" DESC))
;        (setq DESC (vl-string-right-trim "+2" DESC))
;        (setq DESC (vl-string-right-trim "+3" DESC))
(print DESC)
           (if (= (substr ATT 1 1) "X")
               (setq X 1)
               (setq X 0)
           ); end of if
           (if (> (vl-string-search "NO Z" ATT) 0)
               (setq NOZ 1)
               (setq NOZ 0)
           ); end of if
          (setq PNTR (cdr PNT))
          (setq TEMP (reverse PNTR))
          (setq TEMP (cdr TEMP))
          (setq PT (cdr TEMP))
       (if (= NOZ 1)
           (setq ELEV -99)
           (setq ELEV (car TEMP))
       ); end of if
          (setq IP 
            (list (cadr temp) (caddr temp) ELEV))
           (setq IPXY (list (cadr TEMP) (caddr TEMP)))
          (setq m (+ n 1))
          (setq n (+ n 1))
      );end of progn
      (setq n (+ n 1))
        );end of if
    );end of while
       (setq el (rtos ELEV 2 2))
   (command "Layer" "M" FFILE "")
   (if (/= X 1)
       (command "insert" PTDWG ip BLKSCALE BLKSCALE 0 (fix (car pnt)) DESC el)
   );end of if
;    (command "insert" PTDWG ip 1 1 30 (fix (car pnt)) DESC el)
       (print (fix (car pnt)))
   (setq BNAME (vl-string-right-trim "+" (substr ATT 1 2)))
   (setq BNAME (vl-string-right-trim "-" BNAME))
   (setq BNAME (vl-string-right-trim "/" BNAME))
   (setq BNAME (vl-string-right-trim " " BNAME))
   (setq ATTLEN (strlen ATT))
       (setq PENCODE (substr ATT (- ATTLEN 1) 2))
   (if (= PENCODE "+1")
       (progn
           (setq PLVERTS2d (list IPXY))
           (setq PLVERTS (list IP))
           (setq NUMVERTS 1)
       )
   ); end if
       
   (if (= PENCODE "+2")
       (progn
           (setq PLVERTS2d (append PLVERTS2d (list IPXY)))
           (setq PLVERTS (append PLVERTS (list IP)))
           (setq NUMVERTS (+ NUMVERTS 1))
       )
   ); end if    
   (if (= PENCODE "+3")
       (progn
           (setq PLVERTS2d (append PLVERTS2d (list IPXY)))
           (setq PLVERTS (append PLVERTS (list IP)))
           (setq NUMVERTS 0)
           (command "LAYER" "M" BLKLAYER "")
           (command "PLINE" (foreach XXX PLVERTS2d (command XXX)))
           (command "LAYER" "M" (strcat "TOPO3d-" BNAME) "")
           (command "3dpoly" (foreach XXXX PLVERTS (command XXXX)))
           (command "LAYER" "M" FFILE "")
       )
         (if (= (substr ATT (- ATTLEN 1) 2) "+0") 
           (print "no lines"))
   ); end if
;loop to find block name
       (setq BLOCKS (open BLKDIR "r"))
   ;        (print COUNTER99)
   (while (< COUNTER99 10)
             (setq BDATA (read-line BLOCKS))
           (while     (/= BNAME (vl-string-right-trim " " (substr BDATA 1 2)))
               (setq BDATA (read-line BLOCKS))
               
           ) ; end of while
           (READBLOCK)
           ;(if     (= BNAME (substr BDATA 1 2))
           ;    (READBLOCK)
           ;    (setq BDATA (read-line BLOCKS))
           ;    
            ; end of if
   ;        (print BDATA)
           (setq COUNTER99 99)
;            (getstring "STOP")
       ); end of while
       (setq COUNTER99 1)
       (close BLOCKS)
   ;    (PRINT "HOWDY")
   );end of do-it
(defun READBLOCK ( / COUNTER NUMBLOCKS FC)
;     (getstring "READBLOCK MODULE Counter setup")
   (setq
       COUNTER 1
       NUMBLOCKS 143
       FC "AA"
          );end of setq
       (while (< COUNTER (+ NUMBLOCKS 1))
            (setq FC (vl-string-right-trim " " (substr BDATA 1 2)))
           (if (= FC BNAME)
               (progb)
               (setq COUNTER (+ COUNTER 1))
                );end of if
        );end of while
); end of READBLOCK
(defun PROGB ()
       (setq BLKNAME (vl-string-right-trim " " (substr BDATA 9 16)))
   ;        (print BLKNAME)
       (setq BLKLAYER (vl-string-right-trim " " (substr BDATA 25 15)))
   ;        (print BLKLAYER)
           (command "LAYER" "M" BLKLAYER "") 
       (setq BATT (substr BDATA 40 1))
           (if (= (vl-string-right-trim " " (substr BDATA 9 16)) "MISCSYMB")
               (setq BATT "4")); end IF
   (if (= BATT "3")
         (command "insert" BLKNAME ipxy BLKSCALE BLKSCALE 0 "" "" ""))
;          (command "insert" BLKNAME ip 1 1 0 "" "" ""))
   (if (= BATT "2")
         (command "insert" BLKNAME ipxy BLKSCALE BLKSCALE 0 "" ""))
;          (command "insert" BLKNAME ip 1 1 0 "" ""))
   (if (= BATT "1")        
         (command "insert" BLKNAME ipxy BLKSCALE BLKSCALE 0 ""))
;          (command "insert" BLKNAME ip 1 1 0 ""))
   (if (= BATT "0")
       (command "insert" BLKNAME ipxy BLKSCALE BLKSCALE 0 )    
;        (command "insert" BLKNAME ip 1 1 0 )
       )
       
   (setq COUNTER (+ NUMBLOCKS 1))
);end of progb

 
(foreach x '("blockname1" "blockname2" "blockname3" "blockname4")
 (if (not (tblsearch "block" x))
   (progn
     (setvar 'cmdecho 0)
     (command "_.insert" x nil)
     (setvar 'cmdecho 1)
   )
 )
)