;  ###############################################################
;  ##  图形转换到形文件  功能软件  3．0  版      DWG-SHP.LSP    ##
;  ##  适用于 AutoCAD R13  以上版                               ##
;  ##  可转换的实体类型: 直线 _________ Line                    ##
;  ##                    圆弧 _________ Arc                     ##
;  ##                    圆 ___________ Circle                  ##
;  ##                                                           ##
;  ##  限制条件: 1> 每个端点都应尽量落在 1mm 的隐含网格上       ##
;  ##            2> 同一实体的两个相邻点 X,Y 位移小于 127mm     ##
;  ##            3> 直线中大于 127mm 的部分应分为 127mm 的几段  ##
;  ##            4> 大于半圆的弧应分两段绘成,  半径应是整数     ##
;  ##            5> 尽量少用 Arc，非用不可，应在最后绘成 ,      ##
;  ###############################################################

;-- ERROR 错误中断处理 --------------------------------------------
(Defun CPrint (ipl / in)
       (SetQ in 0)
       (While (SetQ ipa (Nth in ipl))
              (If (= 'REL (Type ipa)) (PrinC (RToS ipa)) (PrinC ipa))
              (SetQ in (1+ in))
       )
       (PrinC)
)
(Defun Error (ex2 ey2 ex1 ey1 est / ea exx eyy)
       (SetQ ea (Angle (List ex1 ey1) (List ex2 ey2))
            exx (* 4 (Sin ea)) eyy (* 4 (Cos ea))
       )
       (GrDraw (List ex1 ey1) (List (- ex2 exx)(+ ey2 eyy)) 1 1)
       (GrDraw (List (- ex2 exx)(+ ey2 eyy))
               (List (+ ex2 exx)(- ey2 eyy)) 1 1)
       (GrDraw (List (+ ex2 exx)(- ey2 eyy))(List ex1 ey1) 1 1)
       (If (/= nil ofn3) (Close ofn3))
       (If (/= nil ofn2) (Close ofn2))
       (If (/= nil ofn1) (Close ofn1))
       (Alert (StrCat "\n注意: \n" est "\n请重新修改你的图形，再试一次..."))
       (SetQ ex1 nil ey1 nil ex2 ni ey2 nil)
       (Redraw)(Abcdefg) 
)

;-- 2,8,(dx,dy), 空移的描述和处理 ---------------------------------

(Defun 2-XY()
       (SetQ 2a (Angle (List x0 y0)(List x1 y1))
            2xx (* 2 (Sin 2a)) 2yy (* 2 (Cos 2a))
       )
       (GrDraw (List x1 y1) (List (- x0 2xx)(+ y0 2yy)) 3 1)
       (GrDraw (List (- x0 2xx)(+ y0 2yy))
               (List (+ x0 2xx)(- y0 2yy)) 3 1)
       (GrDraw (List (+ x0 2xx)(- y0 2yy))(List x1 y1) 3 1)
       (SetQ 2dx (- x1 x0) 2dy (- y1 y0) ax (Abs 2dx) ay (Abs 2dy))
       (If (> 0.3 ax)(SetQ ax 0.0))
       (If (> 0.3 ay)(SetQ ay 0.0))
       (If (>= 2dx 0)(SetQ xfh "+")(SetQ xfh "-"))
       (If (>= 2dy 0)(SetQ yfh "+")(SetQ yfh "-"))
       (Cond ((Or (/= 0 2dx)(/= 0 2dy))                ;-> cond1
             (Cond ((Or (> ax 127)(> ay 127))          ;-> cond1-1
                   (Cond ((= ax ay)                    ;-> cond1-2
                          (SetQ dn (RToS (/ ax 127) 2 0)
                               ddd (RToS (rem ax 127) 2 0)
                               sdy (StrCat "2,4," dn
                                           ",8,(" xfh "127," yfh "127,)"
                                           "3," dn
                                           ",8,(" xfh ddd "," yfh ddd "),1,"
                                   )
                              sdyl (+ sdyl 12)
                          )
                          (Write-Line sdy ofn2) (SetQ sdy "")
                         ) ;> ax=ay end
                         ((= ax 0)
                          (SetQ dn (RToS (/ ay 127) 2 0)
                               ddd (RToS (rem ay 127) 2 0)
                               sdy (StrCat "2,4," dn
                                           ",8,(0," yfh "127,)"
                                           "3," dn
                                           ",8,(0," yfh ddd "),1,"
                                   )
                              sdyl (+ sdyl 12)
                          )
                          (Write-Line sdy ofn2) (SetQ sdy "")
                         )  ;> ax=0 end
                         ((= ay 0)
                          (SetQ dn (RToS (/ ax 127) 2 0)
                               ddd (RToS (rem ax 127) 2 0)
                               sdy (StrCat "2,4," dn
                                           ",8,(" xfh "127,0),"
                                           "3," dn
                                           ",8,(" xfh ddd ",0),1,"
                                   )
                              sdyl (+ sdyl 12)
                          )
                          (Write-Line sdy ofn2) (SetQ sdy "")
                         ) ;> ay=0 end
                         (T (Error x0 y0 x1 y1 "距离太长"))
                      )                                 ;> cond1-2 end
                   )                            ;> ax or ay > 127 end
                   (T (SetQ sdy (StrCat "2,8,(" (RToS 2dx 2 0) ","
                                                (RToS 2dy 2 0) "),1,"
                                )
                           sdyl (+ sdyl 5)
                      )
                      (Write-Line sdy ofn2)
                   ) ;> ax and ay < 127 end
             )  ;> cond1-1 end
        )) ;> cond1 end
(SetQ 2dx nil 2dy nil ddd nil xfh nil yfh nil))


;-- ARC 弧实体的转换 ----------------------------------------------

(Defun S-Arc()
       (PrinC "A.")
       (SetQ cr (Cdr (Assoc 40 ent))
              x (Cadr (Assoc 10 ent)) y (Caddr (Assoc 10 ent))
             a1 (Cdr (Assoc 50 ent)) a2 (Cdr (Assoc 51 ent))
            a11 (AToF (angtos a1 0 3)) a22 (AToF (angtos a2 0 3))
             x1 (+ x (* cr (Cos a1))) y1 (+ y (* cr (Sin a1)))
             x2 (+ x (* cr (Cos a2))) y2 (+ y (* cr (Sin a2)))
             dx (- x2 x1) dy (- y2 y1)
       )
       (2-xy)
       (Cond ((And (< (Abs dx) 127.0) (< (Abs dy) 127.0))
             (setq d ( sqrt (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) ))
                   h (- cr ( sqrt (- (* cr cr) (* 0.25 d d))))
                   td  (* (/ (* 2.0 H) D) 127.0)
             )
             (setq dx (rtos dx 2 0) dy (rtos dy 2 0) td (rtos td 2 0) )
             (SetQ sdy (StrCat "12," dx "," dy "," td ",")
                  sdyl (+ sdyl 4)
             )
             (Write-Line sdy ofn2)
        ;     (princ sdy)
              (SetQ sdy "" x0 x2 y0 y2)
             );-> cond T end
             (T (Error x1 y1 x2 y2 "弧线太长 <S-Line>"))
       );-> cond end
)
;-- CIRCLE 圆实体的转换 -------------------------------------------

(Defun S-Circle()
       (PrinC "C.")
       (SetQ cr (Cdr (Assoc 40 ent))
             x1 (+ cr (Cadr (Assoc 10 ent))) y1 (Caddr (Assoc 10 ent))
             cr (RToS cr 2 0)
       )
       (2-XY)
      ; (SetQ sdy (StrCat "4," cr ",7,1,3," cr ",") sdyl (+ sdyl 6))
       (SetQ sdy (StrCat "10," cr ",000," ) sdyl (+ sdyl 3))
       (Write-Line sdy ofn2)(SetQ sdy "" x0 x1 y0 y1 cr nil)
)

;-- LINE 直线实体的转换 -------------------------------------------

(Defun S-Line()
       (PrinC "L.")
       (SetQ x1 (Cadr (Assoc 10 ent)) y1 (Caddr (Assoc 10 ent))
             x2 (Cadr (Assoc 11 ent)) y2 (Caddr (Assoc 11 ent))
             dx (- x2 x1) dy (- y2 y1)
            ddx (RToS dx 2 0) ddy (RToS dy 2 0)
       )
       (2-XY)
       (Cond ((And (< (Abs dx) 127) (< (Abs dy) 127))
              (SetQ sdy (StrCat "8,(" ddx "," ddy "),") sdyl (+ sdyl 3))
              (Write-Line sdy ofn2)
             ; (princ sdy)
              (SetQ sdy "" x0 x2 y0 y2)
             );-> cond T end
             (T (Error x1 y1 x2 y2 "线太长 <S-Line>"))
       );-> cond end
       (SetQ dx nil dy nil ddx nil ddy nil)
)

;-- Write to SHP file 填写形文件 ----------------------------------

(Defun Write-SHP()
       (PrinC "\n正在写入形定义源文件...")
       (Close ofn2)(SetQ ofn2 (open sfn2 "r") ofn1 (open sfn1 "a"))
       (SetQ odyl (RToS (1+ sdyl) 2 0) osno (RToS sno 2 0)
             obtl (StrCat "*" osno "," (rtos (+ 4 (atoi odyl)) 2 0) "," sna)
       )
       (Write-Line obtl ofn1)
       (Write-Line "07,1," ofn1)
       (While (SetQ txt (read-line ofn2)) (Write-Line txt ofn1))
       (Write-Line "07,2,0" ofn1)
       ;(Write-Line "0" ofn1)
   ;    (Write-Line sna ofn3)
       (Close ofn1) (Close ofn2) (Close ofn3)
       (SetQ odyl nil odtl nil)
)

;-- found *.nam file 形名索引的检索处理 & 输入限制 ----------------

(Defun Name-File()
       (SetQ ofn3 (Open sfn3 "r"))
       (While (SetQ rsna (Read-Line ofn3))
              (Cond ((= rsna sna)
                     (PrinC "\n这个形名已经存在了!")
                     (SetQ sna (GetString " 形名: ") sna (StrCase sna))
                     (While (Or (Eq "" sna)(= "SAVE" sna)(= rsna sna))
                            (PrinC "\n请重新起名...")
                            (SetQ sna (GetString " 名: ") sna (StrCase sna))
                     )
                     (Close ofn3)
                     (SetQ ofn3 (Open sfn3 "r"))
                    );-> (= rsna sna)
              ) ;-> cond end
       );-> while end
       (Close ofn3)
       (SetQ ofn3 (Open sfn3 "a"))
)

;== DWG to SHP 图 --> 形  转换功能的主控段落 ======================

;(Defun C:DWG-SHP ()
(Defun C:DS ()
      ; (Defun *error* (st) (SetQ *error* nil) (PrinC))
       (SetQ sfn0 (GetString "\n形文件名: "));-> Input Filename
       (While (Eq sfn0 "");-> "RETURN" err
              (SetQ sfn0 (GetString "\n请确定形文件名: "))
       );-> while end

       (SetQ sfn1 (StrCat sfn0 ".SHP")
             sfn2 (StrCat sfn0 ".BAK")
             sfn3 (StrCat sfn0 ".NAM")
             sdy ""
       )

       (If (SetQ ofn3 (Open sfn3 "r"));-> new or old file
           (Progn (SetQ sno 1)
                  (While (Read-Line ofn3) (SetQ sno (1+ sno)))
                  (PrinC "已有的形定义源文件...")(Close ofn3)
           )
           (Progn (SetQ ofn1 (Open sfn1 "w") ofn3 (Open sfn3 "w"))
                  (Write-Line "C" ofn3)(Close ofn3)
                  (Write-Line "*1,9,C" ofn1)
                  (Write-Line "2,010,1,10,1,000,2,018,0" ofn1)
                  (PrinC "新文件...") (SetQ sno 2)(Close ofn1)
           )
       )

       (CPrint (List "\n形定义 [" sno))
       (SetQ sna (StrCase (GetString "] 名: ")))
       (While (Eq "" sna)
              (SetQ sna (StrCase (GetString " 请输入形定义名: ")))
       )

       (While (And (/= "SAVE" sna)(> 255 sno));-> big while start
              (SetQ ofn2 (Open sfn2 "w") sdyl 0)
              (Name-File)
              (SetQ ;inp (getpoint"\n插入基点: ")
                     x0 (Car inp) y0 (Cadr inp) inp nil
                     x0 0  y0 0
              )
              (PrinC "\n请选定要转换成形定义的图线 ...")
              (SetQ ss (ssget))
              (If (/= nil ss) (SetQ ssn (sslength ss)) (SetQ ssn 0))
              (While (Or (Eq nil ss) (> ssn 1200))
                     (PrinC "\n所选的图线个数是 ")
                     (PrinC (RToS ssn 2 0))
                     (PrinC "\n但是，图线数量限制在 1到 100之间！<dwg-shp>")
                     (SetQ ss (ssget))
                     (If (/= nil ss) (SetQ ssn (sslength ss)) (SetQ ssn 0))

              )
              (SetQ n (- ssn 1))
              (repeat ssn
                      (SetQ ent (EntGet (ssname ss n))
                          etype (Cdr (Assoc 0 ent))
                      )
                      (Cond ((= etype "LINE")(S-Line))
                            ((= etype "ARC")(S-Arc))
                            ((= etype "CIRCLE")(S-Circle))
                            (T (SetQ errp (Cdr (Assoc 10 ent))
                                     errx (Car errp)
                                     erry (Cadr errp)
                               )
                               (Error errx erry (+ errx 10) erry
                                      (StrCat "所指图线中有不能转换的 " etype
                                              "\n 能够转换的对象是: Line、Circle 和 Arc"
                                      )
                               )
                            )
                      )
                      (SetQ n (1- n))
              )
              (SetQ sno (1+ sno))(Write-SHP)
              (PrinC "\nSAVE(存盘）/<形定义[") (PrinC sno)
              (SetQ sna (StrCase (GetString "]名>: ")))
              (While (Eq "" sna)
                     (SetQ sna (StrCase (GetString " 请输入形定义名: ")))
              )
       );-> big while end

       (PrinC "\n形文件: ")(PrinC (StrCase sfn0))
       (PrinC ".SHP 已经存好了。")
       (PrinC "\n感谢您使用我的程序，再见！")
       (PrinC)

)
;== By Chen Bo xiong =========================================================

