home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 6 / 06.iso / b / b002 / 2.ddi / ACDTOIDR.LSP next >
Encoding:
Lisp/Scheme  |  1990-06-14  |  5.6 KB  |  102 lines
  1. ;* Version 2.0, Copyright 1988,1989 Edward Riegelmann, All Rights Reserved.*
  2. (repeat 2 (prompt "\n ")) (prompt "\nLoading CADTOIDR program.....")
  3. (defun c:cadtoidr ()
  4.  (grtext 0 "********") (grtext 1 "CADTOIDR") (grtext 1 " " 1)  
  5.  (grtext 2 "********") (repeat 10 (prompt "\n "))
  6.  (prompt "\n                ╔═════════════════════════════════════════════╗") 
  7.  (prompt "\n                ║                  AutoTOOLS                  ║▐")
  8.  (prompt "\n                ╟─────────────────────────────────────────────╢▐")
  9.  (prompt "\n                ║    AutoCAD TO IDRISI DATA TRANSFORMATION    ║▐")
  10.  (prompt "\n                ╟─────────────────────────────────────────────╢▐")
  11.  (prompt "\n                ║                 Version 2.0                 ║▐")
  12.  (prompt "\n                ╚═════════════════════════════════════════════╝▐")
  13.  (prompt "\n                 ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀")
  14.  (prompt "\n ")
  15.  (prompt "\n                     Copyright 1988, 1989 Edward Riegelmann")
  16.  (repeat 8 (prompt "\n ")) (textscr) (setvar "luprec" 6) (setvar "flatland" 0)
  17.  (setq fn (getstring "\nEnter new vector file name                             : "))
  18.  (setq df (open (strcat fn ".vec") "w")) (initget 1 "W A")
  19.  (setq flg (getkword "\nChoose data by (W)indow or choose (A)ll ?              : "))
  20.  (if (= flg "W") (progn (graphscr)
  21.   (setq pnt1 (getpoint "\nEnter window corner                                    : "))
  22.   (setq pnt2 (getcorner pnt1 "\nEnter other corner                                     : "))
  23.   (prompt "\n ")) (setq pnt1 (getvar "extmin") pnt2 (getvar "extmax"))
  24.  ) (setq a (ssget "C" pnt1 pnt2)) (textscr) 
  25.  (prompt "\nUnadjusted number of ROWS                              : ")
  26.  (princ (- (nth 1 pnt2) (nth 1 pnt1)))
  27.  (prompt "\nUnadjusted number of COLS                              : ")
  28.  (princ (- (nth 0 pnt2) (nth 0 pnt1))) (terpri) (initget 1 "Y N")
  29.  (setq flg3 (getkword "\nDo you wish to re-grid your data (Yes/No) ?            : "))
  30.  (if (= flg3 "Y") (progn (setq xsub (nth 0 pnt1) ysub (nth 1 pnt1))
  31.   (setq xyfac (getreal "\nMultiply coordinates by what factor ?                  : ")))
  32.   (setq xsub 0 ysub 0 xyfac 1)
  33.  ) (initget 1 "P S C L")
  34.  (setq ply (getkword "\nAre data (P)olygons, Point(S), (C)ontours or (L)ines ? : "))
  35.  (prompt "\n                  .................working.................")
  36.  (prompt "\n ") (setq i 0)
  37.  (repeat (sslength a) 
  38.   (setq b (entget (ssname a i)) f 1 f1 1)
  39.   (if (= (cdr (assoc 0 b)) "POLYLINE")
  40.    (if (= ply "C") (progn 
  41.     (setq subent (entget (entnext (cdr (assoc -1 b)))))
  42.     (while f 
  43.      (if (= (nth 3 (assoc 10 subent)) nil) (princ 0 df)
  44.       (princ (rtos (nth 3 (assoc 10 subent))) df)
  45.      ) (write-line " 1" df) 
  46.      (princ (rtos (* (- (nth 1 (assoc 10 subent)) xsub) xyfac)) df) (princ " " df)
  47.      (write-line (rtos (* (- (nth 2 (assoc 10 subent)) ysub) xyfac)) df)
  48.      (setq subent (entget (entnext (cdr (assoc -1 subent)))))
  49.      (if (= (cdr (assoc 0 subent)) "SEQEND") (setq f nil))
  50.     ))
  51.     (progn (setq subent (entget (entnext (cdr (assoc -1 b)))) cnt 1)
  52.      (while f1 
  53.       (setq cnt (1+ cnt))
  54.       (setq subent (entget (entnext (cdr (assoc -1 subent)))))
  55.       (if (= (cdr (assoc 0 subent)) "SEQEND") (setq f1 nil))
  56.      ) (setq subent (entget (entnext (cdr (assoc -1 b)))) subent1 subent)
  57.      (if (= (nth 3 (assoc 10 subent)) nil) (princ 0 df)
  58.       (princ (rtos (nth 3 (assoc 10 subent))) df)
  59.      ) (if (= ply "L") (setq cnt (1- cnt))) 
  60.      (write-line (strcat " " (rtos cnt)) df) 
  61.      (while f 
  62.       (princ (rtos (* (- (nth 1 (assoc 10 subent)) xsub) xyfac)) df) (princ " " df)
  63.       (write-line (rtos (* (- (nth 2 (assoc 10 subent)) ysub) xyfac)) df)
  64.       (setq subent (entget (entnext (cdr (assoc -1 subent)))))
  65.       (if (= (cdr (assoc 0 subent)) "SEQEND") (setq f nil))
  66.      ) 
  67.      (if (= ply "P") (progn 
  68.       (princ (rtos (* (- (nth 1 (assoc 10 subent1)) xsub) xyfac)) df) (princ " " df)
  69.       (write-line (rtos (* (- (nth 2 (assoc 10 subent1)) ysub) xyfac)) df)))
  70.     )
  71.    )
  72.    (progn 
  73.     (if (= (nth 3 (assoc 10 b)) nil) (princ 0 df) 
  74.      (princ (rtos (nth 3 (assoc 10 b))) df)) (write-line " 1" df)
  75.     (princ (rtos (* (- (nth 1 (assoc 10 b)) xsub) xyfac)) df) (princ " " df)
  76.     (write-line (rtos (* (- (nth 2 (assoc 10 b)) ysub) xyfac)) df) 
  77.    ) 
  78.   ) (setq i (1+ i))
  79.  ) 
  80.  (princ 0 df) (write-line " 0" df) (close df)
  81.  (setq rows (- (nth 1 pnt2) (nth 1 pnt1)) cols (- (nth 0 pnt2) (nth 0 pnt1)))
  82.  (setq inf (open (strcat fn ".inf") "w")) 
  83.  (write-line (strcat "(" (rtos (nth 0 pnt1)) " " (rtos (nth 1 pnt1)) ")") inf) 
  84.  (write-line (strcat "(" (rtos (nth 0 pnt2)) " " (rtos (nth 1 pnt2)) ")") inf) 
  85.  (write-line (strcat "(" (rtos (nth 0 pnt1)) " " (rtos (nth 1 pnt2)) ")") inf) 
  86.  (write-line (rtos (* rows xyfac)) inf) (write-line (rtos (* cols xyfac)) inf) 
  87.  (write-line (rtos xyfac) inf) (close inf) (repeat 15 (prompt "\n "))
  88.  (prompt "\n                  █████████████████████████████████████████████") 
  89.  (prompt "\n                  █  ***************************************  █")
  90.  (prompt "\n                  █  Please record the following information  █")
  91.  (prompt "\n                  █  as it is required for processing within  █") 
  92.  (prompt "\n                  █        the IDRISI software package        █")
  93.  (prompt "\n                  █  ***************************************  █")
  94.  (prompt "\n                  █████████████████████████████████████████████") 
  95.  (repeat 5 (prompt "\n "))
  96.  (prompt "\n                              ROWS in data set : ") 
  97.  (princ (fix (1+ (* rows xyfac))))
  98.  (prompt "\n                              COLS in data set : ") 
  99.  (princ (fix (1+ (* cols xyfac)))) (terpri)
  100. ) 
  101.  
  102.