[LISP函数]：请高人指点函数升级问题

longhu · 发表于 2006-10-7 02:03:29

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

我有一个R12的自编LISP函数，到R14中不能执行，请问升级该函数需要注意那些方面，文件在附件中
[php]
(defun c:gd5 () ; / libc pctr h iblipmode icmdecho iosmode iclayer ns ne nb step rept xl dx yl dy sty y0 x1 x2 librat ss lib libn p x r libch libtmp ylr libc)
 (command "undo" "M")
;(setq oerr *error*)
;(setq *error* errr)
 (setq iblipmode (getvar "blipmode"))
 (setq icmdecho (getvar "cmdecho"))
 (setq iosmode (getvar "osmode"))
 (setq iclayer (getvar "clayer"))
 (if (= iclayer "GD5TEXT")
(setq iclayer "0")
 )
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
 (setq libc (ssget))
 (setq libc (texttolib "GD5TEXT" libc))
 (if libc
(progn
 (setq libd1 (car libc))
 (setq libc (cdr libc))
 (setq libc (libtolibc libc))
 (setq ns (atof (nth 0 libd1)))
 (setq ne (atof (nth 1 libd1)))
 (setq nb (atof (nth 2 libd1)))
 (setq step (atof (nth 3 libd1)))
 (setq rept (atof (nth 4 libd1)))
 (setq libn (creatnumber ns ne step rept))
 (setq libn (checklibn libn))
 (setq xl (atof (nth 5 libd1)))
 (setq dx (atof (nth 6 libd1)))
 (setq yl (atof (nth 7 libd1)))
 (setq dy (atof (nth 8 libd1)))
 (setq ylr (/ dy dx))
 (if (nth 9 libd1)
(setq sty (nth 9 libd1))
(setq sty "")
 )
 (setq librat '())
 (princ "\nEnter scale entity: ")
 (setq ss (ssget))
 (setq sst (ssget "X" '((0 . "TEXT") (8 . "GD5TEXT"))))
 (setq ss (ssboolecut ss sst))
 (setq ssd (delgdd ss))
 (setq sse (cadr ssd)
 ss (caddr ssd)
 libchd (last ssd)
 )
 (setq ssd (car ssd))
 (setq libd (gdd ssd))
 (setq libe (gdd sse))
 (setq libntch (getlibntch ss))
 (setq libblock (gd5getblock ss))
 (setq libch (gd5makelibch ss libntch libblock libchd))
 (if (> (length (car libch)) 16)
(progn
 (alert "too many setting, do it in several times")
 (setvar "cmdecho" icmdecho)
 (setvar "osmode" iosmode)
 (setvar "clayer" iclayer)
 (setvar "blipmode" iblipmode)
 (exit)
)
 ) ; (if (> (length (car libch)) 16) (progn
 (setvar "expert" 0)
 (princ "\nPlease wait ...")
 (setq libms (makeslave ss "M" "S"))
 (setq libnt (makeslave ss "N" "T"))
 (setq ss (gd5delslave ss))
 (setq pc (getpoint "\nPlease enter a scale basic point"))
 (if (null pc)
(setq pc '(0 0 0))
 )
 (setq lib (ngd5 (car libch)
 libn
 xl
 dx
 yl
 dy
 nb
 ylr
 librat
 "GD5TEXT"
 libc
)
 )
) ; progn
(progn
 (setq libd (readgd4tmp))
 (setq libd1 '())
 (setq tmp
 (getreal (strcat "\nenter Small number <" (nth 0 libd) ">:")
 )
 )
 (if tmp
(setq ns tmp)
(setq ns (atof (nth 0 libd)))
 )
 (setq libd1 (cons (rtos ns 2 1) libd1))
 (setq tmp
 (getreal (strcat "\nenter End number <" (nth 1 libd) ">:"))
 )
 (if tmp
(setq ne tmp)
(setq ne (atof (nth 1 libd)))
 )
 (setq libd1 (cons (rtos ne 2 1) libd1))
 (setq tmp
 (getreal (strcat "\nenter Basic number <" (nth 2 libd) ">:")
 )
 )
 (if tmp
(setq nb tmp)
(setq nb (atof (nth 2 libd)))
 )
 (setq libd1 (cons (rtos nb 2 1) libd1))
 (setq step (checkstep ns ne nb))
 (setq rept (checkrept ns ne nb))
 (setq libn (creatnumber ns ne step rept))
 (setq nb (checknb libn nb))
 (setq libn (checklibn libn))
 (setq
tmp (getreal (strcat "\nEnter X length <" (nth 3 libd) ">:"))
 )
 (if tmp
(setq xl tmp)
(setq xl (atof (nth 3 libd)))
 )
 (setq libd1 (cons (rtos xl 2 4) libd1))
 (setq tmp (getreal (strcat "\nEnter X step <" (nth 4 libd) ">:")))
 (if tmp
(setq dx tmp)
(setq dx (atof (nth 4 libd)))
 )
 (setq libd1 (cons (rtos dx 2 4) libd1))
 (writegd4tmp libd1)
 (if (or (= step 0.5) (= step 5.0))
(setq dx (* dx 0.5))
 )
 (setq ylr (getstring "\nEnter Y Ratio or Value <Ratio=1>:"))
 (cond
((= "V" (strcase (substr ylr 1 1)))
 (setq yl (getreal "\nEnter Y length:"))
 (setq dy (getreal "\nEnter Y STEP:"))
 (if (or (= step 0.5) (= step 5))
 (setq dy (* dy 0.5))
 )
 (setq ylr (/ dy dx))
) ;
((= ylr "")
 (setq yl xl
 dy dx
 ylr 1
 )
)
(1
 (setq ylr (atof ylr))
 (setq dy (* dx ylr))
 (setq yl xl)
) ; 1
 ) ; cond
 (setq sty (getstring t "\nEnter Style number:"))
 (setq sty (strcase sty))
 (setq libd1 (list (rtos ns 2 1)
(rtos ne 2 1)
(rtos nb 2 1)
(rtos step 2 4)
(rtos rept 2 4)
(rtos xl 2 4)
(rtos dx 2 4)
(rtos yl 2 4)
(rtos dy 2 4)
sty
 )
 )
 (setq librat '())
 (princ "\nEnter scale entity: ")
 (setq ss (ssget))
 (setq sst (ssget "X" '((0 . "TEXT") (8 . "GD5TEXT"))))
 (setq ss (ssboolecut ss sst))
 (setq ssd (delgdd ss))
 (setq sse (cadr ssd)
 ss (caddr ssd)
 libchd (last ssd)
 )
 (setq ssd (car ssd))
 (setq libd (gdd ssd))
 (setq libe (gdd sse))
 (setq libntch (getlibntch ss))
 (setq libblock (gd5getblock ss))
 (setq libch (gd5makelibch ss libntch libblock libchd))
 (if (> (length (car libch)) 16)
(progn
 (alert "too many setting, do it in several times")
 (setvar "cmdecho" icmdecho)
 (setvar "osmode" iosmode)
 (setvar "clayer" iclayer)
 (setvar "blipmode" iblipmode)
 (exit)
)
 ) ; (if (> (length (car libch)) 16) (progn
 (setvar "expert" 0)
 (princ "\nPlease wait ...")
 (setq libms (makeslave ss "M" "S"))
 (setq libnt (makeslave ss "N" "T"))
 (setq ss (gd5delslave ss))
 (setq pc (getpoint "\nPlease enter a scale basic point"))
 (if (null pc)
(setq pc '(0 0 0))
 )
 (setq libc
 (get_libc libn nb xl yl librat dx dy (length (car libch)))
 )
 (setq lib (ngd5 (car libch)
 libn
 xl
 dx
 yl
 dy
 nb
 ylr
 librat
 "GD5TEXT"
 libc
)
 )
) ; progn
 ) ; if libc
 (gd5writelibtext lib libd1 "GD5TEXT")
 (setvar "clayer" "0")
 (setq lib (translibgd5 lib nb (length librat) (length libd)))
 (setq lib (transblockgd5 lib (length librat) nb (length libd)))
 (setq lib (changelibgd5 lib nb (length librat) (length libd)))
 (setq libchj (gd5makelibchj ss))
 (if (> (length libchj) 1)
(progn
 (setq libj (ngd5j libchj libn nb))
 (setq ssj (getssj ss))
 (setq ss (cadr ssj))
 (setq ssj (car ssj))
 (gd5ratelibj lib libj ssj libchj pc)
) ; progn

 ) ; (if (> (length libchj) 1)
 (setvar "blipmode" 0)
 (setvar "osmode" 0)
 (gd5ratelib
lib nb librat ss sty libch libms libnt pc libd libe)
 (setvar "cmdecho" icmdecho)
 (setvar "osmode" iosmode)
 (setvar "clayer" iclayer)
 (setvar "blipmode" iblipmode)
;(setq *error* oerr)
) ; defun c:gd2( / iblipmode icmdecho iosmode iclayer ns ne nb step rept xl dx yl dy sty y0 x1 x2 librat ss lib libn p x r libch libtmp)

(defun errr (msg)
 (if msg
(command "undo" "b")
(setq *error* nil)
 ) ;
) ; defun

(defun getssj (ss / ssj ssk i n)
 (setq ssj (ssadd)
ssk (ssadd)
i 0
n (sslength ss)
 )
 (while (< i n)
(setq en (ssname ss i))
(if (= "INSERT" (cdr (assoc 0 (entget en))))
 (if (wcmatch (cdr (assoc 2 (entget en))) "J@#")
(setq ssj (ssadd en ssj))
(setq ssk (ssadd en ssk))
 ) ; if (wcmatch (cdr (assoc 2 (entget en))) "J@#")
 (setq ssk (ssadd en ssk))
) ; if (= "INSERT" (cdr (assoc 0 (entget en))))
(setq i (1+ i))
 ) ; while (< i n)
 (list ssj ssk)
) ; defun getssj(ss / ssj ssk i n)

(defun ngd5j (libch libn nb / n i libc lib nx ny ix iy j lib1 lib2 nn
 key)
 (setq nx (length libn)
ny (length libch)
 )
 (setq n (1+ (fix (/ (1- nx) 12)))
i 0
libc '()
ix 0
 )
 (while ( nn nx)
 (setq nn nx)
)
(while (< ix nn)
 (setq lib1 '())
 (setq lib1 (cons (rtos (nth ix libn) 2 4) lib1))
 (setq j 0)
 (while (< j ny)
(setq lib1 (cons "" lib1))
(setq j (1+ j))
 ) ; (while (< j ny)
 (setq lib2 (cons (reverse lib1) lib2))
 (setq ix (1+ ix))
) ; while(< ix nn)
(setq lib2 (cons i (reverse lib2)))
(setq libc (cons lib2 libc))
(setq i (1+ i))
 ) ;while ( nx (* (1+ i) 12))
 (setq m 12)
 (setq m (- nx (* i 12)))
)
(mklj "gd5" libch m)
(setq lib (dclgd2j "gd5" (cdr (assoc i libc)) ylr))
(setq key (car lib))
(setq lib (cdr lib))
(cond
 ((= key -2) (exit))
 (1 (setq libc (subst (cons i lib) (assoc i libc) libc)))
) ; cond
(if (< (setq i (+ i key)) 0)
 (setq i 0)
)
 ) ; while (and (< i n) (/= key 0))
 (setq i 0
lib '()
 )
 (while (< i n)
(setq lib (append (cdr (nth i libc)) lib))
(setq i (1+ i))
 ) ; while (< i n)
 (setq lib lib)
) ; defun ngd5j(libch libn xl dx yl dy nb / n i libc lib nx ny ix iy j lib1 lib2 nn key)

(defun dclgd2j (st lib ylr / key kk dcl_id i j n m lib1)
 (setq kk (findfile (strcat "c:\\" st ".dcl")))
 (setq dcl_id (load_dialog kk))
 (if (< dcl_id 0)
(exit)
 )
 (if (not (new_dialog st dcl_id))
(exit)
 )
 (setq i 0
n (length lib)
m (length (car lib))
 )
 (while (< i n)
(setq j 0
 lib1 (nth i lib)
)
(while (< j m)
 (set_tile (strcat (chr (+ i 65)) (chr (+ j 65)))
(nth j lib1)
 )
 (setq j (1+ j))
) ; while (< j m)
(setq i (1+ i))
 ) ; while (< i n)
 (action_tile "cancel" "(setq key -2)(done_dialog)")
 (action_tile
"accept"
"(setq key 0)(setq lib (dclokgd2 n ny))(done_dialog)"
 )
 (action_tile
"next"
"(setq key 1)(setq lib (dclokgd2 n ny))(done_dialog)"
 )
 (action_tile
"last"
"(setq key -1)(setq lib (dclokgd2 n ny))(done_dialog)"
 )
 (setq i 0)
 (start_dialog)
 (unload_dialog dcl_id)
 (cons key lib)
) ; defun dclgd2(st lib / key kk dcl_id i j n m lib1)

(defun mklj (ch libch n / m kk j i)
 (setq m (length libch))
 (setq kk (strcat "c:\\" ch ".dcl"))
 (setq ftemp (open kk "w"))
;====(defun filehead(ftemp ch libch / j m)
 (write-line (strcat ch ":dialog{label = \" GD5 \";") ftemp)
 (write-line ":row{" ftemp)
 (setq j 0)
 (write-line ":column{" ftemp)
 (while (< j m)
(write-line
 (strcat ": edit_box { label = \""
 (nth j libch)
 "\"; edit_width = 4; key = \"A"
 (chr (+ j 65))
 "\";}"
 )
 ftemp
)
(setq j (1+ j))
 ) ; while (< j m)
 (write-line "}" ftemp)
;====(defun filebody(ftemp n m / i j)
 (setq i 1)
 (while (< i n)
(write-line ":column{" ftemp)
(setq j 0)
(while (< j m)
 (write-line
(strcat ": edit_box { edit_width = 4; key = \""
(chr (+ i 65))
(chr (+ j 65))
"\";fixed_width = true;}"
)
ftemp
 )
 (setq j (1+ j))
) ; while (< j m)
(write-line "}" ftemp)
(setq i (1+ i))
 ) ; while (< i n)
;===(defun fileend(ftemp)
 (write-line "}" ftemp)
 (write-line ": row {" ftemp)
 (write-line
": button { label = \" LAST \"; key = \"last\";}"
ftemp
 )
 (write-line
": button { label = \" NEXT \"; key = \"next\";}"
ftemp
 )
 (write-line "ok_cancel;}}" ftemp)
 (close ftemp)
) ; defun mklj

(defun gd5makelibchj (ss / n i lib en ch lid)
 (setq n (sslength ss)
i 0
lib '("no")
 )
 (while (< i n)
(setq en (ssname ss i))
(setq ch (cdr (assoc 0 (entget en))))
(setq lid (cdr (assoc 2 (entget en))))
(if (and (= "INSERT" ch) (wcmatch lid "J@#"))
 (progn
(setq lid (substr lid 1 2))
(if (null (member lid lib))
 (setq lib (cons lid lib))
)
 )
) ; if
(setq i (1+ i))
 ) ; while (< i n)
 (reverse lib)
) ; defun gd5makelibchj(ss)

(defun gd5getblock (ss / n i en libblock1 libblock2 ch)
 (setq n (sslength ss)
i 0
libblock '()
 )
 (while (< i n)
(setq en (ssname ss i))
(if (= (cdr (assoc 0 (entget en))) "INSERT")
 (progn
(setq ch (cdr (assoc 2 (entget en))))
(cond
 ((wcmatch ch "GD5??")
 (setq libblock1 (cons "e" libblock1))
 (setq libblock1 (cons ch libblock1))
 ) ; (if (wcmatch ch "GD5??")
 ((wcmatch ch "PHILIP@#")
 (setq libblock2 (cons (substr ch 7) libblock2))
 ) ; (if (wcmatch ch "PHILIP@#")
) ; cond
 )
) ; (if (= (cdr (assoc 0 (entget en))) "INSERT") (progn
(setq i (1+ i))
 ) ; while (< i n)
 (append libblock1 libblock2)
) ; defun gd5getblock(ss / n i en libblock1 libblock2 ch)

(defun gd5delslave (ss / n i ss1 en lid)
 (setq n (sslength ss)
i 0
ss1 (ssadd)
 )
 (while (< i n)
(setq en (ssname ss i))
(setq lid (cdr (assoc 8 (entget en))))
(if (null (member (substr lid 1 1) '("T" "S")))
 (setq ss1 (ssadd en ss1))
)
(setq i (1+ i))
 ) ; while (< i n)
 (eval ss1)
) ; (defun gd5delslave(ss / n i ss1 en lid)

(defun readgd4tmp (/ fst libd ch)
 (if (setq fst (open "c:\\gd.tmp" "r"))
(progn
 (setq libd '())
 (while (setq ch (read-line fst))
(setq libd (cons ch libd))
 ) ; while (setq ch (read-line fst))
 (close fst)
 (if (/= 5 (length libd))
(setq libd '("3" "5" "4" "230" "9"))
 )
) ; progn
(setq libd '("3" "5" "4" "230" "9"))
 ) ; if
 (setq libd libd)
) ; defun readgd4tmp(/ fst libd ch)

(defun writegd4tmp (libd1 / n i fst)
 (setq fst (open "c:\\gd.tmp" "w"))
 (setq n 5
i 0
 )
 (while (< i n)
(write-line (nth i libd1) fst)
(setq i (1+ i))
 ) ; while (< i n)
 (close fst)
) ; defun writegd4tmp(libd1 / n i fst)

(defun getlibntch (ss / lid libntch ssn en n i check)
 (setq lid (tblnext "layer" T))
 (setq libntch '())
 (while lid
(setq lid (cdr (assoc 2 lid)))
(if (= "N" (substr lid 1 1))
 (if (setq ssn (ssget "X" (list (cons 8 lid))))
(progn
 (setq n (sslength ssn)
i 0
check 1
 )
 (while (and (< i n) check)
 (setq en (ssname ssn i))
 (if (ssmemb en ss)
 (progn
(setq check nil)
(setq libntch (cons (substr lid 1 3) libntch))
 ) ; progn
 (setq i (1+ i))
 ) ; if
 ) ;(while (and (< i n) check)
)
 ) ; progn if
) ; if
(setq lid (tblnext "layer"))
 ) ; while lid
 (setq libntch libntch)
) ; defun getlibms(ss / lid libms ssn en n i check)

(defun makeslave (ss ch1 ch2 / lid ssm enm libm en libslist sss n i ens
 lib libpp)
 (setvar "osmode" 0)
 (setq lid (tblnext "layer" T)
lib '()
 )
 (while lid
(princ ".")
(setq lid (cdr (assoc 2 lid)))
(if (and (= (substr lid 1 1) ch1) (> (strlen lid) 3))
 (if (setq ssm (ssget "X" (list (cons 8 lid))))
(if (= (sslength ssm) 1)
 (progn
 (setq enm (ssname ssm 0))
 (if (ssmemb enm ss)
 (progn
(setq libm (creatlib enm))
(setq lid (strcat ch2 (substr lid 2 2) "*"))
(setq libslist '())
(if (setq sss (ssget "X" (list (cons 8 lid))))
 (progn
 (setq libpp (getlibpp (substr lid 1 3)))
 (setq n (sslength sss)
 i 0
 )
 (while ( (strlen lids) 3)
(setq libslist
 (cons (list ens
 (getlibspr ens libm libpp)
 )
 libslist
 )
)
 ) ; if
 (setq i (1+ i))
 ) ; while (< i n)
 (setq libslist (cons enm libslist))
 (setq lib (cons libslist lib))
 )
) ; (if (setq sss (ssget "X" (list (cons 8 lid)))) (progn
 )
 ) ;(if (ssmemb ss enm) (progn
 ) ; progn
 (alert (strcat lid " is wrong in entity number"))
) ; (if (= (sslength ssm) 1)
 ) ; (if (setq ssm (ssget "X" (list (cons 8 lid))))
) ; (if (= (substr lid 1 1) ch1)
(setq lid (tblnext "layer"))
 ) ; while lid
 (setq lib lib)
) ; defun makeslave(ss ch)

(defun getlibpp (lid / ss lib n i en)
 (setq lib '())
 (if (setq ss (ssget "X" (list (cons 8 lid) '(0 . "LINE"))))
(progn
 (setq n (sslength ss)
 i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(setq lib (cons (line_to_lib en) lib))
(setq i (1+ i))
 ) ; while (< i n)
)
 ) ; (if (setq ss (ssget "X" (list (cons 8 lid) (cons 0 line)))) (progn
 (setq lib lib)
) ; (defun getlibpp(lid / ss lib n i en p1 p2)

(defun getlibspr
 (ens libm libpp / libs libpr n i p pctr h i1 pa pb s p1)
 (setq st (cdr (assoc 0 (entget ens))))
 (setq libpr '())
 (cond
((= st "POLYLINE")
 (setq libs (creatlib ens))
 (setq n (length libs)
 i 0
 )
 (while (< i n)
 (setq p (nth i libs))
 (if (setq pp (assoc p libpp))
 (setq p1 (cadr pp))
 (setq p1 (nep p libm))
 ) ; (if (setq pp (assoc p libpp))
 (setq i1 (getlibposit p1 libm))
 (setq pa (nth i1 libm)
 pb (nth (1- i1) libm)
 )
 (setq s (/ (distance p1 (nth i1 libm))
 (distance (nth (1- i1) libm) (nth i1 libm))
 )
 )
 (setq libpr (cons (list i1
 s
 (- (angle p1 p) (angle pa pb))
 (distance p1 p)
 )
 libpr
 )
 )
 (setq i (1+ i))
 ) ; while (< i n)
) ; ((= st "POLYLINE")
((= st "LINE")
 (setq p (cdr (assoc 10 (entget ens))))
 (setq p1 (nep p libm))
 (setq i1 (getlibposit p1 libm))
 (setq pa (nth i1 libm)
 pb (nth (1- i1) libm)
 )
 (setq s (/ (distance p1 (nth i1 libm))
(distance (nth (1- i1) libm) (nth i1 libm))
 )
 )
 (setq libpr (cons (list i1
 s
 (- (angle p1 p) (angle pa pb))
 (distance p1 p)
 )
 libpr
 )
 )
 (setq p (cdr (assoc 11 (entget ens))))
 (setq p1 (nep p libm))
 (setq i1 (getlibposit p1 libm))
 (setq pa (nth i1 libm)
 pb (nth (1- i1) libm)
 )
 (setq s (/ (distance p1 (nth i1 libm))
(distance (nth (1- i1) libm) (nth i1 libm))
 )
 )
 (setq libpr (cons (list i1
 s
 (- (angle p1 p) (angle pa pb))
 (distance p1 p)
 )
 libpr
 )
 )
) ; ((= st "LINE")
((= st "ARC")
 (setq p (cdr (assoc 10 (entget ens))))
 (setq r (cdr (assoc 40 (entget ens))))
 (setq a1 (cdr (assoc 50 (entget ens))))
 (setq a2 (cdr (assoc 51 (entget ens))))
 (setq pt1 (polar p a1 r))
 (setq pt2 (polar p (* (+ a1 a2) 0.5) r))
 (setq pt3 (polar p a2 r))
 (setq libp (list pt1 pt2 pt3))
 (setq i 0
 n 3
 )
 (while (< i n)
 (setq p (nth i libp))
 (setq p1 (nep p libm))
 (setq i1 (getlibposit p1 libm))
 (setq pa (nth i1 libm)
 pb (nth (1- i1) libm)
 )
 (setq s (/ (distance p1 (nth i1 libm))
 (distance (nth (1- i1) libm) (nth i1 libm))
 )
 )
 (setq libpr (cons (list i1
 s
 (- (angle p1 p) (angle pa pb))
 (distance p1 p)
 )
 libpr
 )
 )
 (setq i (1+ i))
 ) ; while (< i n)
) ; ((= st "ARC")
(1
 (setq p (cdr (assoc 10 (entget ens))))
 (setq p1 (nep p libm))
 (setq i1 (getlibposit p1 libm))
 (setq pa (nth i1 libm)
 pb (nth (1- i1) libm)
 )
 (setq s (/ (distance p1 (nth i1 libm))
(distance (nth (1- i1) libm) (nth i1 libm))
 )
 )
 (setq libpr (cons (list i1
 s
 (- (angle p1 p) (angle pa pb))
 (distance p1 p)
 )
 libpr
 )
 )
) ; 1
 ) ; cond
 (reverse libpr)
) ; defun getlibspr(ens libm libpp / libs libpr n i p pctr h i1 pa pb s p1)

(defun getlibposit (p1 libm / check i pa n pb)
 (setq check 1
i 1
pa (car libm)
n (length libm)
 )
 (while (and check (< i n))
(setq pb (nth i libm))
(if (< (- (+ (distance p1 pa) (distance p1 pb)) (distance pa pb))
 0.00001
)
 (setq check nil)
 (setq i (1+ i))
) ; if
(setq pa pb)
 ) ; while (and check (< i n))
 (eval i)
) ; defun getlibposit(p1 libm / check i pa n pb)

(defun changelibgd5 (lib nb nr nd / i j n m nr libb l2 lib1 lib2 lib3)
 (setq i 0
n (length lib)
m (length (car lib))
lib1 '()
 )
 (setq libb (assoc nb lib)
md (1- m)
nr (+ nr 3)
 )
 (setq m (- md nd))
 (while (< i n)
(setq lib2 (nth i lib))
(setq lib3 '())
(setq lib3 (cons (car lib2) lib3))
(setq j 1)
(while (< j nr)
 (setq lib3 (cons (/ (nth j lib2) (nth j libb)) lib3))
 (setq j (1+ j))
) ; while (< j nr)
(while (< j m)
 (setq l2 (mapcar '/ (nth j lib2) (nth j libb)))
 (setq lib3 (cons l2 lib3))
 (setq j (1+ j))
) ; while (< j m)
(while (< j md)
 (setq lib3 (cons (nth j lib2) lib3))
 (setq j (1+ j))
) ; while (< j md)
(setq lib3 (cons (last lib2) lib3))
(setq lib1 (cons (reverse lib3) lib1))
(setq i (1+ i))
 ) ; while (< i n)
 (reverse lib1)
) ; defun changelibgd5(lib nb nr nd / i j n m nr libb l2 lib1 lib2 lib3)

(defun ngd5 (libch libn xl dx yl dy nb ylr librat
 lid libc / n i lib nx ny ix iy j
 lib1 lib2 nn key
 )
 (setq nx (length libn)
ny (length libch)
 )
 (setq n (1+ (fix (/ (1- nx) 12)))
ix 0
 )
 (setq i 0
key 1
 )
 (while (and ( nx (* (1+ i) 12))
 (setq m 12)
 (setq m (- nx (* i 12)))
)
(mkl "gd2" libch m)
(setq lib (dclgd2 "gd2" (cdr (assoc i libc)) ylr))
(setq key (car lib))
(setq lib (cdr lib))
(cond
 ((= key -2) (exit))
 (1 (setq libc (subst (cons i lib) (assoc i libc) libc)))
) ; cond
(if (< (setq i (+ i key)) 0)
 (setq i 0)
)
 ) ; while
 (setq i 0
lib '()
 )
 (while (< i n)
(setq lib (append (cdr (nth i libc)) lib))
(setq i (1+ i))
 ) ; while
 (setq lib lib)
) ; defun ngd5(libch libn xl dx yl dy nb / n i libc lib nx ny ix iy j lib1 lib2 nn key)

(defun libtolibc (lib / nx ny n i ix li2 libc nn)
 (setq nx (length lib)
ny (length (car lib))
 )
 (setq n (1+ (fix (/ (1- nx) 12)))
i 0
ix 0
 )
 (while ( nn nx)
 (setq nn nx)
)
(while (< ix nn)
 (setq lib2 (cons (nth ix lib) lib2))
 (setq ix (1+ ix))
) ; (while (< ix nn)
(setq lib2 (cons i (reverse lib2)))
(setq libc (cons lib2 libc))
(setq i (1+ i))
 ) ; while (< i n)
 (reverse libc)
) ; defun

(defun get_libc (libn nb xl yl librat dx dy ny / i j iy libc ix nn lib1
 lib2)
 (setq nx (length libn))
 (setq n (1+ (fix (/ (1- nx) 12)))
ix 0
 )
 (setq libc '()
i 0
ix 0
 )
 (while ( nn nx)
 (setq nn nx)
)
(while (< ix nn)
 (setq lib1 '())
 (setq lib1 (cons (rtos (nth ix libn) 2 4) lib1))
 (if (= (nth ix libn) nb)
(progn
 (setq lib1 (cons (rtos xl 2 4) lib1))
 (setq lib1 (cons (rtos yl 2 4) lib1))
 (setq iy (+ (length librat) 3)
j 3
 )
 (while (< j iy)
 (setq lib1 (cons (cadr (nth (- j 3) librat) 2 4) lib1))
 (setq j (1+ j))
 ) ; while
) ; progn
(progn
 (setq lib1 (cons (rtos dx 2 4) lib1))
 (setq lib1 (cons (rtos dy 2 4) lib1))
 (setq iy 3)
) ; progn
 ) ; if
 (while (< iy ny)
(setq lib1 (cons "" lib1))
(setq iy (1+ iy))
 ) ; while (< iy ny)
 (setq lib1 (cons "1" lib1))
 (setq lib2 (cons (reverse lib1) lib2))
 (setq ix (1+ ix))
) ; while(< ix nn)
(setq lib2 (cons i (reverse lib2)))
(setq libc (cons lib2 libc))
(setq i (1+ i))
 ) ;while (< i n)
 (setq libc libc)
) ; defun

(defun gd5makelibch
 (ss libms libblock libchd / n i libch en lid lib p ch)
 (setq n (sslength ss)
i 0
libch '("y" "x" "no")
lib '()
 )
 (while (< i n)
(setq en (ssname ss i))
(setq ch (cdr (assoc 0 (entget en))))
(setq lid (cdr (assoc 8 (entget en))))
(if (and (= "POINT" ch) (wcmatch lid "##-*"))
 (progn
(setq lid (substr lid 1 2))
(if (assoc lid lib)
 (alert (strcat "Repeat point at" lid))
 (progn
 (setq libch (cons lid libch))
 (setq p (cdr (assoc 10 (entget en))))
 (setq lib (cons (list lid p) lib))
 ) ; progn
) ; if
 )
) ; if
(setq i (1+ i))
 ) ; while
 (setq n (length libms)
i 0
 )
 (while (< i n)
(setq ch (nth i libms))
(setq libch (cons ch libch))
(setq i (1+ i))
 ) ; while
 (setq n (length libblock)
i 0
 )
 (while (< i n)
(setq ch (nth i libblock))
(setq libch (cons ch libch))
(setq i (1+ i))
 ) ; while
 (setq n (length libchd)
i 0
 )
 (while (< i n)
(setq ch (nth i libchd))
(setq libch (cons ch libch))
(setq i (1+ i))
 ) ; while
 (setq libch (reverse libch)
lib (reverse lib)
 )
 (list libch lib)
) ; defun gd5makelibch(ss)

(defun gd5ratelib (lib nb librat ss sty libch libms
 libnt pc libd libe / n i
 en lid lch flg p0 k libmsnt
 libch1 idch check
 )
 (setq libch1 (car libch))
 (setq libch (cadr libch))
 (setq n (sslength ss)
i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(setq ch (cdr (assoc 0 (entget en))))
(setq lid (cdr (assoc 8 (entget en))))
(cond
 ((= "POLYLINE" ch)
 (if (null (member (substr lid 1 1) '("S" "T")))
 (progn
 (setq idch 0
 check 1
 )
 (cond
 ((= (substr lid 1 1) "N")
 (while check
(if (= (substr lid 1 3) (nth idch libch1))
 (setq check nil)
 (setq idch (1+ idch))
) ; (if (= lid (nth i libch1))
 ) ; while check
 (setq lid (substr lid 4))
 (setq libmsnt (assoc en libnt))
 ) ; ((= (substr lid 1 1) "M")
 ((= (substr lid 1 1) "M")
 (setq lid (substr lid 4))
 (setq libmsnt (assoc en libms))
 ) ; ((= (substr lid 1 1) "M")
 (1 (setq libmsnt '()))
 ) ; cond
 (cond
 ((wcmatch lid "####@-*")
 (gd5rateo en pc lib lid)
 ) ; ((wcmatch lid "####@-*")
 ((wcmatch lid "A##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5rate1 en
pc
p0
lib
k
(substr lid 4)
idch
libmsnt
libch
libd
libe
 )
 ) ; ((wcmatch lid "A##*")
 ((wcmatch lid "B##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5rate2 en
pc
p0
lib
k
(substr lid 4)
idch
libmsnt
libch
libd
libe
 )
 ) ; (wcmatch lid "B##*")
 ((setq lch (assoc (substr lid 1 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5rate2 en pc p0 lib k lid idch libmsnt libch libd libe)
 ) ; ((setq lch (assoc lid libch))
 (1
 (gd5rate0 en pc lib lid idch libmsnt libch1 libd libe)
 ) ; 1
 ) ; cond
 )
 ) ; (if (null (member (substr lid 1 1) '("S" "T"))) (progn
 ) ; "POLYLINE"
 ((= "CIRCLE" ch)
 (cond
 ((wcmatch lid "A##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratec1 en pc p0 lib k (substr lid 4))
 ) ; ((wcmatch lid "A##*")
 ((wcmatch lid "B##*")
 (gd5ratec2 en pc lib (substr lid 4))
 ) ; (wcmatch lid "B##")
 ((setq lch (assoc (substr lid 1 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratec1 en pc p0 lib k lid)
 ) ; ((setq lch (assoc lid libch))
 ((wcmatch lid "C*")
 (gd5ratec3 en pc lib (substr lid 2))
 ) ; (wcmatch lid "C*")
 (1
 (gd5ratec2 en pc lib lid)
 ) ; 1
 ) ; cond
 ) ; CIRCLE
 ((= "INSERT" ch)
 (setq blch (cdr (assoc 2 (entget en))))
 (cond
 ((wcmatch blch "GD5?0")
 (setq k (nthlib blch libch1))
 (gd5rateb en pc lib k sty)
 ) ; ((wcmatch blch "GD5?0")
 ((wcmatch blch "PHILIPB#")
 (setq k (nthlib (substr blch 7) libch1))
 (gd5ratenbl en pc lib k sty)
 ) ; ((wcmatch blch "PHILIPB#")
 ((wcmatch lid "A##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratei1 en pc p0 lib k (substr lid 4) sty)
 ) ; ((wcmatch lid "A##*")
 ((wcmatch lid "B##*")
 (gd5ratei2 en pc lib (substr lid 4) sty)
 ) ; ((wcmatch lid "B##*")
 ((setq lch (assoc (substr lid 1 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratei1 en pc p0 lib k lid sty)
 ) ; ((setq lch (assoc lid libch))
 (1
 (gd5ratei2 en pc lib lid sty)
 ) ; 1
 ) ; cond
 ) ; "INSERT"
 ((= "TEXT" ch)
 (setq ch (cdr (assoc 1 (entget en))))
 (if (null (member (substr ch 1 3) '("GD5" "gd5")))
 (cond
 ((wcmatch lid "A##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratet1 en pc p0 lib k (substr lid 4))
 ) ; ((wcmatch lid "A##*")
 ((wcmatch lid "B##*")
 (gd5ratet2 en pc lib (substr lid 4))
 ) ; ((wcmatch lid "B##*")
 ((setq lch (assoc (substr lid 1 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratet1 en pc p0 lib k lid)
 ) ; ((setq lch (assoc lid libch))
 (1
 (gd5ratet2 en pc lib lid)
 ) ; 1
 ) ; cond
 ) ; (if (null (member (substr ch 1 3) '("GD5" "gd5")))
 ) ; "TEXT"
 ((= "ARC" ch)
 (cond
 ((wcmatch lid "A##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratea1 en pc p0 lib k (substr lid 4))
 ) ; (wcmatch lid "A##*")
 ((wcmatch lid "B##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratea2 en pc lib (substr lid 4))
 ) ; ((wcmatch lid "B##*")
 ((setq lch (assoc (substr lid 1 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratea1 en pc p0 lib k lid)
 ) ; ((setq lch (assoc lid libch))
 (1
 (gd5ratea0 en pc lib lid)
 ) ; 1
 ) ; cond
 ) ; "ARC"
 ((= "LINE" ch)
 (setq idch 0
 check 1
 )
 (cond
 ((wcmatch lid "N##*")
 (while check
 (if (= (substr lid 1 3) (nth idch libch1))
 (setq check nil)
 (setq idch (1+ idch))
 ) ; (if (= lid (nth i libch1))
 ) ; while check
 (setq lid (substr lid 4))
 (setq libmsnt (assoc en libnt))
 ) ; ((wcmatch lid "N##*")
 ((wcmatch lid "M##*")
 (setq lid (substr lid 4))
 (setq libmsnt (assoc en libms))
 ) ; ((wcmatch lid "M##*")
 (1 (setq libmsnt '()))
 ) ; cond
 (cond
 ((wcmatch lid "A##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratel1 en
 pc
 p0
 lib
 k
 (substr lid 4)
 idch
 libmsnt
 libch1
 libd
 libe
 )
 ) ; ((wcmatch lid "A##*")
 ((wcmatch lid "B##*")
 (setq lch (assoc (substr lid 2 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratel2 en
 pc
 p0
 lib
 k
 (substr lid 4)
 idch
 libmsnt
 libch1
 libd
 libe
 )
 ) ; ((wcmatch lid "B##*")
 ((setq lch (assoc (substr lid 1 2) libch))
 (setq p0 (cadr lch))
 (setq k (get_order lch libch))
 (gd5ratel1 en
 pc
 p0
 lib
 k
 (substr lid 4)
 idch
 libmsnt
 libch1
 libd
 libe
 )
 ) ; ((setq lch (assoc lid libch))
 (1
 (gd5ratel0 en pc lib lid idch libmsnt libch1 libd libe)
 ) ; 1
 ) ; cond
 ) ; "LINE"
) ; cond
(setq i (1+ i))
 ) ; while (< i n)
) ; defun gd5ratelib(lib nb librat ss sty libch libms libnt / pc n i en lid lch flg p0 k)

(defun gd5ratenbl (en pc lib k sty / n i p1 p2
 lib1 lib2 sxk syk st ssk k1 k2 enk blchk
 lid libp p3 r a1 a2 p4 p5 nlid
 )
 (setq n (length lib)
i 0
 )
 (setq p1 (cdr (assoc 10 (entget en))))
 (setq nlid (cdr (assoc 8 (entget en))))
 (while (< i n)
(setq lib1 (nth i lib))
(setq lib2 (nth k lib1))
(setq sxk (car lib2)
 syk (cadr lib2)
)
(if (= (last lib1) 1)
 (progn
(setq st (fix (* (car lib1) 10)))
(setq st (itoa st))
(if (= (strlen st) 2)
 (setq st (strcat "0" st))
)
(if (> (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq p2 (gd5scale p1 pc (cadr lib1) (caddr lib1)))
(command "copy" en "" p1 p2)
(command "explode" (entlast))
(setq ssk (ssget "P"))
(setq k2 (sslength ssk)
 k1 0
)
(while (< k1 k2)
 (setq enk (ssname ssk k1))
 (setq blchk (cdr (assoc 0 (entget enk))))
 (setq lid (cdr (assoc 8 (entget enk))))
 (if (null (wcmatch lid "##-*"))
 (setq lid (strcat (substr nlid 1 3) lid))
 )
 (setq lid (strcat lid "-" st))
 (if (null (tblsearch "layer" lid))
 (command "layer" "n" lid "")
 )
 (setvar "clayer" lid)
 (cond
 ((= blchk "POLYLINE")
 (setq libp (creatlib enk))
 (blchpline libp p2 sxk syk)
 ) ;(= blchk "PLINE")
 ((= blchk "ARC")
 (setq libp (arc_to_pline enk))
 (blchpline libp p2 sxk syk)
 (command "pedit" (entlast) "f" "")
 ) ;(= blchk "ARC")
 ((= blchk "LINE")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (setq p4 (cdr (assoc 11 (entget enk))))
 (setq p3 (gd5scale p3 p2 sxk syk))
 (setq p4 (gd5scale p4 p2 sxk syk))
 (command "line" p3 p4 "")
 ) ;(= blchk "LINE")
 ((= blchk "CIRCLE")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (setq p3 (gd5scale p3 p2 sxk syk))
 (setq r (cdr (assoc 40 (entget enk))))
 (setq r (* r sxk))
 (command "circle" p3 r)
 ) ;(= blchk "CIRCLE")
 ((= blchk "TEXT")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (setq p31 (gd5scale p3 p2 sxk syk))
 (command "copy" enk "" p3 p31)
 (command "change"
 (entlast)
 ""
 "P"
 "la"
 (getvar "clayer")
 ""
 )
 ) ;(= blchk "TEXT")
 ((= blchk "INSERT")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (command "copy" enk "" p3)
 (setq p3 (gd5scale p3 p2 sxk syk))
 (command p3)
 (COMMAND "EXPLODE" (ENTLAST))
 (changelid (ssget "P") st nlid)
 ) ;(= blchk "INSERT")
 ) ; cond
 (entdel enk)
 (setq k1 (1+ k1))
) ; (while (< k1 k2)
 )
) ; (if (= (last lib) 1)
(setq i (1+ i))
 ) ; while
) ; defun

(defun gd5rateb (en pc lib k sty / n i p1 lib1 lib2
 sxj syj sxk syk st p ssj m j enj p2
 ssk k1 k2 enk blchk lid libp p3 r a1
 a2 p4 p5 text aj nlid
)
 (setq nlid (cdr (assoc 8 (entget en))))
 (setq n (length lib)
i 0
 )
 (setq p1 (cdr (assoc 10 (entget en))))
 (while (< i n)
(setq lib1 (nth i lib))
(setq lib2 (nth k lib1))
(setq sxj (car lib2)
 syj (cadr lib2)
)
(setq lib2 (nth (1+ k) lib1))
(setq sxk (car lib2)
 syk (cadr lib2)
)
(if (= (last lib1) 1)
 (progn
(setq st (fix (* (car lib1) 10)))
(setq st (itoa st))
(if (= (strlen st) 2)
 (setq st (strcat "0" st))
)
(if (> (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq p (gd5scale p1 pc (cadr lib1) (caddr lib1)))
(command "copy" en "" p1 p)
(command "explode" (entlast))
(setq ssj (ssget "P"))
(setq m (sslength ssj)
 j 0
)
(while (< j m)
 (setq enj (ssname ssj j))
 (if (= (cdr (assoc 0 (entget enj))) "INSERT")
 (progn
 (setq p2 (cdr (assoc 10 (entget enj))))
 (command "copy" enj "" p2)
 (setq p2 (gd5scale p2 p sxj syj))
 (command p2)
 (command "explode" (entlast))
 (setq ssk (ssget "P"))
 (setq k2 (sslength ssk)
 k1 0
 )
 (while (< k1 k2)
(setq enk (ssname ssk k1))
(setq blchk (cdr (assoc 0 (entget enk))))
(setq lid (cdr (assoc 8 (entget enk))))
(if (null (wcmatch lid "##-*"))
 (setq lid (strcat (substr nlid 1 3) lid))
)
(setq lid (strcat lid "-" st))
(if (null (tblsearch "layer" lid))
 (command "layer" "n" lid "")
)
(setvar "clayer" lid)
(cond
 ((= blchk "POLYLINE")
 (setq libp (creatlib enk))
 (blchpline libp p2 sxk syk)
 ) ;(= blchk "PLINE")
 ((= blchk "ARC")
 (setq libp (arc_to_pline enk))
 (blchpline libp p2 sxk syk)
 (command "pedit" (entlast) "f" "")
 ) ;(= blchk "ARC")
 ((= blchk "LINE")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (setq p4 (cdr (assoc 11 (entget enk))))
 (setq p3 (gd5scale p3 p2 sxk syk))
 (setq p4 (gd5scale p4 p2 sxk syk))
 (command "line" p3 p4 "")
 ) ;(= blchk "LINE")
 ((= blchk "CIRCLE")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (setq p3 (gd5scale p3 p2 sxk syk))
 (setq r (cdr (assoc 40 (entget enk))))
 (setq r (* r sxk))
 (command "circle" p3 r)
 ) ;(= blchk "CIRCLE")
 ((= blchk "TEXT")
 (if
 (null (wcmatch (cdr (assoc 1 (entget enk))) "GD5*")
 )
 (progn
(setq p3 (cdr (assoc 10 (entget enk))))
(setq p31 (gd5scale p3 p2 sxk syk))
(command "copy" enk "" p3 p31)
(command "change"
 (entlast)
 ""
 "P"
 "la"
 (getvar "clayer")
 ""
)
 )
 ) ; (if (null (wcmatch (cdr (assoc 1 (entget enk))) "GD5*")) (progn
 ) ;(= blchk "TEXT")
 ((= blchk "INSERT")
 (setq p3 (cdr (assoc 10 (entget enk))))
 (command "copy" enk "" p3)
 (setq p3 (gd5scale p3 p2 sxk syk))
 (command p3)
 (COMMAND "EXPLODE" (ENTLAST))
 (changelid (ssget "P") st lid)
 ) ;(= blchk "INSERT")
) ; cond
(entdel enk)
(setq k1 (1+ k1))
 ) ; (while (< k1 k2)
 )
 ) ; (if (= (cdr (assoc 0 (entget enj))) "INSERT") (progn
 (entdel enj)
 (setq j (1+ j))
) ; (while (< j m)
 )
) ; (if (= (last lib) 1)
(setq i (1+ i))
 ) ; while (< i n)
) ; defun

(defun blchpline (libp p2 sxk syk / libk n i p)
 (setq libk '()
n (length libp)
i 0
 )
 (while (< i n)
(setq p (nth i libp))
(setq p (gd5scale p p2 sxk syk))
(setq libk (cons p libk))
(setq i (1+ i))
 ) ; while
 (drawlib (reverse libk))
) ; defun blchpline(libp p2 sxk syk / libk n i p)

(defun gd5ratet1 (en pc p0 lib k lid / lib1 p n i st p1)
 (setq n (length lib)
i 0
 )
 (setq p1 (cdr (assoc 10 (entget en))))
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setq p (getpt_1 p1 pc p0 lib1 k))
(command "copy" en "" p1 p)
(command "change" (entlast) "" "P" "la" st "")
 )
) ; if progn
(setq i (1+ i))
 ) ; while
) ; defun

(defun gd5ratet2 (en pc lib lid / lib1 p n i st r p1)
 (setq n (length lib)
i 0
 )
 (setq p1 (cdr (assoc 10 (entget en))))
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setq p (gd5scale p1 pc (cadr lib1) (caddr lib1)))
(command "copy" en "" p1 p)
(command "change" (entlast) "" "P" "la" st "")
 )
) ; if progn
(setq i (1+ i))
 ) ; while
) ; defun

(defun gd5ratei1
 (en pc p0 lib k lid sty / lib1 p n i st p1 sx sy a ch1)
 (setq ch1 (cdr (assoc 2 (entget en))))
 (setq p1 (cdr (assoc 10 (entget en))))
 (setq n (length lib)
i 0
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq p (getpt_1 p1 pc p0 lib1 k))
(if (= ch1 "PHTEXT")
 (progn
 (setq st (strcat "-" st))
 (newritext en p sty styno st)
 ) ; progn
 (progn
 (command "copy" en "" p1 p)
 (COMMAND "EXPLODE" (ENTLAST))
 (changelid2 (substr lid 1 3) (ssget "P") st)
 ) ; progn
) ; if
 )
) ; if progn
(setq i (1+ i))
 ) ; while
) ; defun

(defun changelid2 (ch ss st / n i en lid l)
 (setq l (strlen st))
 (if (> l 3)
(setq st (substr st (- l 2)))
 )
 (if (/= (substr ch 3 1) "-")
(setq ch "")
 )
 (setq n (sslength ss)
i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(setq lid (cdr (assoc 8 (entget en))))
(setq lid (strcat ch lid "-" st))
(if (null (tblsearch "layer" lid))
 (command "layer" "n" lid "")
)
(command "change" en "" "P" "la" lid "")
(setq i (1+ i))
 ) ;(while (< i n)
) ; defun changelid2(ss st / n i en lid)

(defun gd5ratei2 (en pc lib lid sty / lib1 p n i st p1 sx sy a ch1)
 (setq ch1 (cdr (assoc 2 (entget en))))
 (setq p1 (cdr (assoc 10 (entget en))))
 (setq n (length lib)
i 0
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq p (gd5scale p1 pc (cadr lib1) (caddr lib1)))
(if (= ch1 "PHTEXT")
 (progn
 (setq st (strcat "-" st))
 (newritext en p sty styno st)
 ) ; progn
 (progn
 (command "copy" en "" p1 p)
 (COMMAND "EXPLODE" (ENTLAST))
 (changelid2 (substr lid 1 3) (ssget "P") st)
 ) ; progn
) ; if
 )
) ; if progn
(setq i (1+ i))
 ) ; while
) ; defun

(defun gd5ratec1 (en pc p0 lib k lid / lib1 p n i st r p1 r0 st)
 (setq p1 (cdr (assoc 10 (entget en))))
 (setq r0 (cdr (assoc 40 (entget en))))
 (setq n (length lib)
i 0
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq p (getpt_1 p1 pc p0 lib1 k))
(setq r (* r0 (cadr lib1)))
(command "circle" p r)
 )
) ; if progn
(setq i (1+ i))
 ) ; while
) ; defun

(defun gd5ratec2 (en pc lib lid / lib1 p n i st r p1 r0 st rc check)
 (setq p1 (cdr (assoc 10 (entget en))))
 (setq r0 (cdr (assoc 40 (entget en))))
 (cond
((= (getenv "CADUNIT") "CM") (setq sc 0.35))
((= (getenv "CADUNIT") "MM") (setq sc 3.5))
(1 (setq sc 0.125))
 ) ; cond
 (if (< r0 sc)
(setq check nil
 r r0
)
(setq check 1)
 )
 (setq n (length lib)
i 0
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq p (gd5scale p1 pc (cadr lib1) (caddr lib1)))
(if check
 (setq r (* r0 (cadr lib1)))
)
(command "circle" p r)
 )
) ; if progn
(setq i (1+ i))
 ) ; while
) ; defun

(defun gd5ratec3 (en pc lib lid / i n lib1 libp check libpp r st)
 (setq libp (cir_to_pline en))
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq libpp (gd5scalib libp pc (cadr lib1) (caddr lib1)))
(drawlib libpp)
(command "pedit" (entlast) "F" "")
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5ratec3

(defun getpt_1 (p1 pc p0 lib1 k / p ps)
 (setq p (gd5scale p0 pc (cadr lib1) (caddr lib1)))
 (setq p0 (mapcar '- p p0))
 (setq p1 (mapcar '+ p1 p0))
 (setq ps (nth k lib1))
 (gd5scale p1 p (car ps) (cadr ps))
) ; defun

(defun long (libp / i n p1 p2 s)
 (setq n (length libp)
i 1
p1 (car libp)
s 0
 )
 (while (< i n)
(setq p2 (nth i libp))
(setq s (+ (distance p1 p2) s))
(setq i (1+ i))
(setq p1 p2)
 ) ; whle
 (eval s)
) ; defun

(defun get_order (lch libch / i n check)
 (setq i 0
n (length libch)
check 1
 )
 (while check
(if (equal lch (nth i libch))
 (setq check nil)
 (setq i (1+ i))
) ; if
 ) ; while
 (+ i 3)
) ; defun get_order(lch libch / i n check)

(defun nthlib (en lib / n i check)
 (setq n (length lib)
i 0
check 1
 )
 (while (and (< i n) check)
(if (= en (nth i lib))
 (setq check nil)
 (setq i (1+ i))
)
 ) ; (while (and (< i n) check)
 (eval i)
) ; defun nthlib(en lib / n i check)

(defun check_pt (pt / n i p1 p2 p dmin d)
 (setq n (sslength pt)
i 1
p1 (ssname pt 1)
 )
 (while (< i 0)
(setq p2 (ssname pt i))
(setq p1 p2)
(setq i (1+ i))
 ) ; while
 (while (null (setq p1 (getpoint "\nEnter a point from such line")))
 )
 (setq i 1
p (ssname pt 0)
 )
 (setq dmin (distance p1 p))
 (while (< i n)
(setq p2 (ssname pt i))
(setq d (distance p1 p2))
(if (< d dmin)
 (setq dmin d
 p p2
 )
)
(setq i (1+ i))
 ) ; while
 (setq p1 p)
) ; defun

(defun gd5scalib (libp pt1 sx sy / n i lib pt)
 (setq n (length libp)
i 0
lib '()
 )
 (while (< i n)
(setq pt (nth i libp))
(setq pt (gd5scale pt pt1 sx sy))
(setq lib (cons pt lib))
(setq i (1+ i))
 ) ; while
 (reverse lib)
) ; defun gd5scalib

(defun gd5scale (pt pc sx sy / ps)
 (setq ps (list sx sy 1))
 (setq pt (mapcar '- pt pc))
 (setq pt (mapcar '* pt ps))
 (mapcar '+ pt pc)
) ; defun gd5

(defun creatlib
 (en / ent clib p err k key p1 b d pc r a x m j da ratio)
 (setq err 0.0001
clib '()
 )
 (setq k (cdr (assoc 70 (entget en))))
 (setq key (boole 1 k 4))
 (setq ent (entnext en))
 (if (= key 4)
(while (/= 8 (cdr (assoc 70 (entget ent))))
 (setq ent (entnext ent))
) ; while
 ) ; if
 (setq clib (list (cdr (assoc 10 (entget ent)))))
 (setq x (cdr (assoc 42 (entget ent))))
 (setq ent (entnext ent))
 (while (= (cdr (assoc 0 (entget ent))) "VERTEX")
(if (= key 4)
 (if (= 8 (cdr (assoc 70 (entget ent))))
(setq p (cdr (assoc 10 (entget ent))))
 )
 (setq p (cdr (assoc 10 (entget ent))))
) ; if
(if (= x 0)
 (if (> (distance p (car clib)) err)
(setq clib (cons p clib))
 )
 (progn
(setq p1 (car clib))
(setq b (* (distance p1 p) 0.5))
(setq d (* (/ (* (1+ x) (1- x)) 2 x) b))
(setq pc (polar p1 (angle p1 p) b))
(setq pc (polar pc (- (angle p1 p) (* pi 0.5)) d))
(setq r (distance pc p1))
(setq a (- (angle pc p) (angle pc p1)))
(if (< (* a x) 0)
 (if (< a 0)
 (setq a (+ a (* pi 2)))
 (setq a (- a (* pi 2)))
 ) ; if
) ; if
(cond
 ((= (getenv "cadunit") "CM") (setq ratio 1.18)) ; cm
 ((= (getenv "cadunit") "MM") (setq ratio 0.118)) ; mm
 (1 (setq ratio 3.0)) ; in
) ; cond
(setq m (1+ (fix (* (abs a) r ratio))))
(if (< m 3)
 (setq m 3)
)
(setq da (/ a m)
 j 1
)
(while (<= j m)
 (setq p (polar pc (+ (angle pc p1) (* da j)) r))
 (setq clib (cons p clib))
 (setq j (1+ j))
) ; while
 ) ; progn
) ; if
(setq x (cdr (assoc 42 (entget ent))))
(setq ent (entnext ent))
 ) ; while (p)
 (if (= (boole 1 k 1) 1)
(setq clib (cons (last clib) clib))
 )
 (reverse clib)
) ; defun creatlib(en / ent clib p err k key p1 b d pc r a x m j da)

(defun drawlib (lib / i n)
 (setq i 1
n (length lib)
 )
 (if (> n 1)
(progn
 (if (equal (car lib) (last lib) 0.0001)
(command "pline")
(command "pline" (car lib))
 ) ; if
 (while (< i n)
(command (nth i lib))
(setq i (1+ i))
 ) ; while
 (if (equal (car lib) (last lib) 0.0001)
(command "c")
(command "")
 ) ; if
)
 ) ; if progn
) ; defun drawlib(lib / i n)

(defun checkstep (ns ne nb / step)
 (cond
((> 20 ne)
 (setq step (+ (rem ns 1) (rem ne 1) (rem nb 1)))
 (if (< step 0.5)
 (progn
 (setq step (getstring "\nHalf number <Y/N> (N):"))
 (if (= "Y" (strcase (substr step 1 1)))
 (setq step 0.5)
 (setq step 1.0)
 ) ; if
 ) ; progn
 (setq step 0.5)
 ) ; if
) ; America
((< 99 ns)
 (setq step (+ (rem ns 10) (rem ne 10) (rem nb 10)))
 (if (< step 5)
 (progn
 (setq step (getstring "\nHalf number <Y/N> (N):"))
 (if (= "Y" (strcase (substr step 1 1)))
 (setq step 5)
 (setq step 10)
 ) ; if
 ) ; progn
 (setq step 5)
 ) ; if
) ; Japan
(1 (setq step 1)) ; Europe
 ) ; cond
 (eval step)
) ; defun checkstep(ns ne nb / step)

(defun checkrept (ns ne nb / rept)
 (cond
((> ns 13.5) (setq rept 0))
((or (> ns nb) (> nb ne)) (setq rept 1))
(1
 (setq rept (getstring "\nRepeat <Y/N> (N):"))
 (if (wcmatch rept "Y*,y*")
 (setq rept 1)
 (setq rept 0)
 )
) ;
 ) ; cond
 (eval rept)
) ; defun checkrept(ns ne nb / rept)

(defun checknb (libn nb / i n check)
 (setq n (length libn)
i 0
check 0
 )
 (while (= check 0)
(while (< i n)
 (if (= nb (nth i libn))
(setq check (1+ check))
 )
 (setq i (1+ i))
) ; while
(if (= check 0)
 (progn
(setq nb (getreal "\nEnter Correct Basic Number:"))
(setq i 0)
 )
) ; if
 ) ; while
 (if (= check 2)
(progn
 (setq check
 (getstring "\nEnter Basic Number Big or Small <B/S> (S)")
 )
 (if (= "B" (strcase (substr check 1 1)))
(setq nb (+ nb 0.1))
 )
)
 ) ; if
 (eval nb)
) ; defun checknb(libn nb / i n check)

(defun creatnumber (i n step rept / lib)
 (setq lib '())
 (while (or (< i n) (= rept 1))
(setq lib (cons n lib))
(setq n (- n step))
(if (and (< n 1) rept)
 (setq n (- 14.0 step)
 rept 0
 )
)
 ) ; while
 (cons i lib)
) ; defun creatnumber(i n step rept / lib)

(defun checklibn (libn / i n lib e)
 (setq n (length libn)
i 0
lib '()
 )
 (while (< i n)
(setq e (nth i libn))
(if (member e lib)
 (setq lib (cons (+ e 0.1) lib))
 (setq lib (cons e lib))
) ; if
(setq i (1+ i))
 ) ; while
 (reverse lib)
) ; defun checklibn(libn / i n lib e)

(defun mkl (ch libch n / kk ftemp m)
 (setq m (length libch))
 (setq kk (strcat "c:\\" ch ".dcl"))
 (setq ftemp (open kk "w"))
 (filehead ftemp ch libch)
 (filebody ftemp n m)
 (fileend ftemp)
 (close ftemp)
) ; defun mkl(ch libch n / kk ftemp m)

(defun filehead (ftemp ch libch / j m)
 (write-line (strcat ch ":dialog{label = \" GD2 \";") ftemp)
 (write-line ":row{" ftemp)
 (setq j 0
m (length libch)
 )
 (write-line ":column{" ftemp)
 (write-line ":row{" ftemp)
 (write-line ":text{label=\"on/off\";}" ftemp)
 (write-line
(strcat ": toggle { key = \"A" (chr (+ m 65)) "\";}")
ftemp
 )
 (write-line "}" ftemp)
 (while (< j m)
(write-line
 (strcat ": edit_box { label = \""
 (nth j libch)
 "\"; edit_width = 4; key = \"A"
 (chr (+ j 65))
 "\";}"
 )
 ftemp
)
(setq j (1+ j))
 ) ; while
 (write-line "}" ftemp)
) ; defun filehead(ftemp ch libch / j m)

(defun filebody (ftemp n m / i j)
 (setq i 1)
 (while (< i n)
(write-line ":column{" ftemp)
(write-line
 (strcat ": toggle { key = \""
 (chr (+ i 65))
 (chr (+ m 65))
 "\";}"
 )
 ftemp
)
(setq j 0)
(while (< j m)
 (write-line
(strcat ": edit_box { edit_width = 4; key = \""
(chr (+ i 65))
(chr (+ j 65))
"\";fixed_width = true;}"
)
ftemp
 )
 (setq j (1+ j))
) ; while
(write-line "}" ftemp)
(setq i (1+ i))
 ) ; while
) ; defun filebody(ftemp n m / i j)

(defun fileend (ftemp)
 (write-line "}" ftemp)
 (write-line ": row {" ftemp)
 (write-line
": button { label = \" LAST \"; key = \"last\";}"
ftemp
 )
 (write-line
": button { label = \" NEXT \"; key = \"next\";}"
ftemp
 )
 (write-line "ok_cancel;}}" ftemp)
) ; defun fileend

(defun dclgd2 (st lib ylr / key kk dcl_id i j n m lib1)
 (setq kk (findfile (strcat "c:\\" st ".dcl")))
 (setq dcl_id (load_dialog kk))
 (if (< dcl_id 0)
(exit)
 )
 (if (not (new_dialog st dcl_id))
(exit)
 )
 (setq i 0
n (length lib)
m (length (car lib))
 )
 (while (< i n)
(setq j 0
 lib1 (nth i lib)
)
(while (< j m)
 (set_tile (strcat (chr (+ i 65)) (chr (+ j 65)))
(nth j lib1)
 )
 (setq j (1+ j))
) ; while
(setq i (1+ i))
 ) ; while
 (action_tile "cancel" "(setq key -2)(done_dialog)")
 (action_tile
"accept"
"(setq key 0)(setq lib (dclokgd2 n ny))(done_dialog)"
 )
 (action_tile
"next"
"(setq key 1)(setq lib (dclokgd2 n ny))(done_dialog)"
 )
 (action_tile
"last"
"(setq key -1)(setq lib (dclokgd2 n ny))(done_dialog)"
 )
 (setq i 0)
 (while (< i n)
(action_tile
 (strcat (chr (+ i 65)) "B")
 (strcat "(change_y \"" (chr (+ i 65)) "\" ylr)")
)
(setq i (1+ i))
 ) ; while
 (start_dialog)
 (unload_dialog dcl_id)
 (cons key lib)
) ; defun dclgd2(st lib / key kk dcl_id i j n m lib1)

(defun change_y (i ylr / y)
 (setq y (get_tile (strcat i "B")))
 (setq y (atof y))
 (setq y (* y ylr))
 (setq y (rtos y 2 4))
 (set_tile (strcat i "C") y)
) ; defun change_y(j)

(defun dclokgd2 (nx ny / lib i j lib1)
 (setq i 0
lib '()
 )
 (while (< i nx)
(setq j 0
 lib1 '()
)
(while (<= j ny)
 (setq
lib1 (cons (get_tile (strcat (chr (+ i 65)) (chr (+ j 65))))
 lib1
 )
 )
 (setq j (1+ j))
) ; while ny
(setq lib (cons (reverse lib1) lib))
(setq i (1+ i))
 ) ; while nx
 (reverse lib)
) ; defun dclokgd2(nx ny / lib i j lib1)

(defun translibgd5 (lib nb nr nd / n m md i j libb lib0 lib1 lib2 lib3
 ib e0 ch)
 (setq n (length lib)
m (length (car lib))
i 0
lib3 '()
 )
 (while (< i n)
(setq lib1 (nth i lib)
 j 0
 lib2 '()
)
(while (< j m)
 (setq lib2 (cons (strtof (nth j lib1)) lib2))
 (setq j (1+ j))
) ; while (< j m)
(setq lib2 (reverse lib2))
(if (= (car lib2) nb)
 (setq ib i)
)
(setq lib3 (cons lib2 lib3))
(setq i (1+ i))
 ) ; while (= i 0)
(setq lib1 (nth i lib)
 lib2 '()
 j 3
)
(setq lib2 (cons (car lib1) lib2))
(setq lib2 (cons (- (cadr libb) (cadr lib1)) lib2))
(setq lib2 (cons (- (caddr libb) (caddr lib1)) lib2))
(while (< j nr)
 (setq e0 (nth j lib1))
 (if (= e0 0)
(setq lib2 (cons (nth j libb) lib2))
(setq lib2 (cons e0 lib2))
 ) ; if
 (setq j (1+ j))
) ; while nr
(while (< j (- m nd))
 (setq e0 (nth j lib1))
 (cond
((= (nth j lib0) 0)
 (if (assoc e0 lib)
 (setq lib2 (cons e0 lib2))
 (setq lib2 (cons (nth j libb) lib2))
 ) ; if
) ;
((listp e0)
 (setq lib2 (cons e0 lib2))
) ; (listp e0)
((> e0 0)
 (setq lib2 (cons (list e0 e0) lib2))
) ;
(1
 (setq lib2 (cons (nth j libb) lib2))
)
 ) ; cond
 (setq j (1+ j))
) ; while (< j (- m nd))
(while (< j m)
 (setq e0 (nth j lib1))
 (setq et (nth j libb))
 (cond
((listp e0)
 (setq e0 (list (- (car et) (car e0)) (cadr e0) (caddr et)))
) ; (listp e0)
((> e0 0)
 (setq e0 (list (- (car et) e0) 0 (caddr et)))
) ;
(1
 (setq e0 et)
) ; 1
 ) ; cond
 (setq lib2 (cons e0 lib2))
 (setq j (1+ j))
) ; while m
(setq lib2 (cons (last lib1) lib2))
(setq libb (reverse lib2))
(setq lib3 (cons libb lib3))
(setq i (1- i))
 ) ; while
 (setq i (1+ ib)
libb lib0
lib3 (reverse lib3)
 )
 (setq libb (car lib3))
 (while (< i n)
(setq lib1 (nth i lib)
 lib2 '()
 j 3
)
(setq lib2 (cons (car lib1) lib2))
(setq lib2 (cons (+ (cadr libb) (cadr lib1)) lib2))
(setq lib2 (cons (+ (caddr libb) (caddr lib1)) lib2))
(while (< j nr)
 (setq e0 (nth j lib1))
 (if (= e0 0)
(setq lib2 (cons (nth j libb) lib2))
(setq lib2 (cons e0 lib2))
 ) ; if
 (setq j (1+ j))
) ; while nr
(while (< j (- m nd))
 (setq e0 (nth j lib1))
 (cond
((= (nth j lib0) 0)
 (if (assoc e0 lib)
 (setq lib2 (cons e0 lib2))
 (setq lib2 (cons (nth j libb) lib2))
 ) ; if
)
((listp e0)
 (setq lib2 (cons e0 lib2))
)
((> e0 0)
 (setq lib2 (cons (list e0 e0) lib2))
) ;
(1
 (setq lib2 (cons (nth j libb) lib2))
)
 ) ; cond
 (setq j (1+ j))
) ; while (< j (- m nd))
(while (< j m)
 (setq e0 (nth j lib1))
 (setq et (nth j libb))
 (cond
((listp e0)
 (setq e0 (list (+ (car et) (car e0)) (cadr e0) (caddr et)))
) ; (listp e0)
((> e0 0)
 (setq e0 (list (+ (car et) e0) 0 (caddr et)))
) ; (> e0 0)
(1
 (setq e0 et)
) ; 1
 ) ; cond
 (setq lib2 (cons e0 lib2))
 (setq j (1+ j))
) ; while m
(setq lib2 (cons (last lib1) lib2))
(setq libb (reverse lib2))
(setq lib3 (cons libb lib3))
(setq i (1+ i))
 ) ; while
 (reverse lib3)
) ; defun translibgd5(lib nb nr nd / n m i j libb lib0 lib1 lib2 lib3 ib e0)

(defun basiclibgd5 (lib0 nb nr m nd / j libb e0)
 (setq j 0
libb '()
 )
 (while (< j nr)
(setq libb (cons (nth j lib0) libb))
(setq j (1+ j))
 ) ; while
 (while (< j (- m nd))
(setq e0 (nth j lib0))
(cond
 ((= e0 0)
 (setq libb (cons nb libb))
 ) ; 0
 ((listp e0)
 (setq libb (cons e0 libb))
 ) ; (listp e0)
 (1
 (setq libb (cons (list e0 e0) libb))
 ) ; 1
) ; cond
(setq j (1+ j))
 ) ; while (< j (- m nd))
 (while (< j m)
(setq e0 (nth j lib0))
(setq libb (cons (list 0 0 e0) libb))
(setq j (1+ j))
 ) ; while (< j m)
 (setq libb (cons (last lib0) libb))
 (reverse libb)
) ; defun basiclibgd5(lib0 nb nr m nd / j libb e0)

(defun transblockgd5 (lib nr nb nd / libb nx m i j
 lib0 lib1 lib2 libc xb yb x1 y1 e id
 check
 )
 (setq libb (assoc nb lib))
 (setq xb (cadr libb)
yb (caddr libb)
 )
 (setq md (1- (length libb))
nr (+ nr 3)
 )
 (setq m (- md nd))
 (setq nx (length lib)
i 0
 )
 (while (< i nx)
(setq j 0
 lib1 (nth i lib)
 lib2 '()
)
(while (< j nr)
 (setq lib2 (cons (nth j lib1) lib2))
 (setq j (1+ j))
) ; while
(while (< j m)
 (setq check (nth j lib1))
 (cond
((listp check)
 (setq lib2 (cons check lib2))
) ; (listp check
((setq lib0 (assoc check lib))
 (setq x1 (cadr lib0)
 y1 (caddr lib0)
 )
 (setq lib2 (cons (list x1 y1) lib2))
) ;
(1
 (print lib)
 (getpoint "error")
) ;
 ) ; cond
 (setq j (1+ j))
) ; while
(while (< j md)
 (setq lib2 (cons (nth j lib1) lib2))
 (setq j (1+ j))
) ; while
(setq lib2 (cons (last lib1) lib2))
(setq libc (cons (reverse lib2) libc))
(setq i (1+ i))
 ) ; while
 (reverse libc)
) ; defun transblockgd5(lib nr nb nd / libb nx m i j lib0 lib1 lib2 libc xb yb x1 y1 e id check)

(defun strtof (ch / n i check n1 n2)
 (cond
((wcmatch ch "*;*")
 (setq n (strlen ch)
 i 1
 check 1
 )
 (while (and (<= i n) check)
 (if (= (substr ch i 1) ",")
 (setq check nil)
 (setq i (1+ i))
 )
 ) ; while
 (setq n1 (atof (substr ch 1 (1- i))))
 (setq n2 (atof (substr ch (1+ i))))
 (setq n1 (list n1 n2))
) ; (wcmatch ch "*,*")
((wcmatch ch "*h*,*H*")
 (setq n1 (atof ch))
 (setq n2 1)
 (setq n1 (list n1 n2))
) ; (wcmatch ch "*h*,*H*")
(1
 (setq n1 (atof ch))
) ; 1
 ) ; cond
 (setq n1 n1)
) ; defun strtof(ch / n i check n1 n2)

(defun newritext (en p sty styno st / a lid h as n i p1)
 (setq n (sslength ss)
i 0
 )
 (cond
((= (getenv "cadunit") "CM") (setq h 0.3)) ; cm
((= (getenv "cadunit") "MM") (setq h 3.0)) ; mm
(1 (setq h 0.12)) ; in
 ) ; cond
 (command "style" "CHINA" "" h "" "" "" "" "")
 (setq lid (cdr (assoc 8 (entget en))))
 (setq lid (substr lid 1 2))
 (setq lid (strcat lid "-1" st))
 (if (null (tblsearch "layer" lid))
(command "layer" "n" lid "")
 )
 (setvar "clayer" lid)
 (setq a (cdr (assoc 50 (entget en))))
 (setq as (angtos a))
 (setq p1 (polar p (+ a (* pi 1.5)) (* h 0.2)))
 (if (> (strlen sty) 0)
(command "text" "J" "TC" p1 as sty)
 )
 (command "text" p as (itoa (fix styno)))
 (setq p (polar p a (* h (strlen (itoa (fix styno))))))
 (if (> (rem styno 1) 0.3)
(progn
 (command "style" "CHINA" "" (* h 0.5) "" "" "" "" "")
 (command "text" p as "2")
 (setq p (polar p (+ (* pi 0.5) a) (* h 0.6)))
 (command "text" p as "/")
 (setq p (polar p (+ (* pi 0.5) a) (* h 0.4)))
 (command "text" p as "1")
 (command "style" "CHINA" "" h "" "" "" "" "")
 (setq p (polar p a (* h 0.5)))
) ; progn
(setq p (polar p (+ (* pi 0.5) a) h))
 ) ; if
 (command "text" p as "#")
) ; defun writext(sty y0 r0 x1 x2 librat styno st / libp ss en p a lid h as n i)

(defun arc_to_pline (en / pc pr a1 a2 n da i libp)
 (setq pc (cdr (assoc 10 (entget en))))
 (setq r (cdr (assoc 40 (entget en))))
 (setq a1 (cdr (assoc 50 (entget en))))
 (setq a2 (cdr (assoc 51 (entget en))))
 (if (< (setq da (- a2 a1)) 0)
(setq da (+ da (* pi 2)))
 )
 (cond
((= (getenv "cadunit") "CM") (setq ratio 1.18)) ; cm
((= (getenv "cadunit") "MM") (setq ratio 0.118)) ; mm
(1 (setq ratio 3.0)) ; in
 ) ; cond
 (setq n (1+ (fix (* da r ratio)))
i 0
 )
 (if (< n 3)
(setq n 3)
 )
 (setq da (/ da n))
 (while (<= i n)
(setq libp (cons (polar pc (+ (* da i) a1) r) libp))
(setq i (1+ i))
 ) ; while
 (reverse libp)
) ; defun arc_to_pline(en / pc pr a1 a2 n da i libp)

(defun gd5ratea0 (en pc lib lid / i n lib1 libp libpp st)
 (setq libp (arc_to_pline en))
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq libpp (gd5scalib libp pc (cadr lib1) (caddr lib1)))
(drawlib libpp)
(command "pedit" (entlast) "F" "")
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5ratea0

(defun gd5ratea1 (en pc p0 lib k lid / libp p1 p2 pt1 pt2 dp1 dp2 n i s
 da pa pb ds m j)
 (setq libp (arc_to_pline en))
 (setq p1 (car libp))
 (setq p2 (last libp))
 (if (> (distance p1 p0) (distance p2 p0))
(progn
 (setq libp (reverse libp))
 (setq p1 (car libp)
 p2 (last libp)
 )
)
 ) ; progn if
 (setq m (length lib)
j 0
 )
 (while (< j m)
(setq lib1 (nth j lib))
(if (= (last lib1) 1)
 (progn
(setq st (fix (* (car lib1) 10)))
(setq st (itoa st))
(if (= (strlen st) 2)
 (setq st (strcat "0" st))
)
(if (> (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq pt1 (getpt_1 p1 pc p0 lib1 k))
(setq pt2 (gd5scale p2 pc (cadr lib1) (caddr lib1)))
(setq dp1 (mapcar '- pt1 p1))
(setq dp2 (mapcar '- pt2 p2))
(setq n (length libp)
 i 1
)
(setq s (long libp)
 ds 0
 pa (car libp)
)
(setq s (mapcar '/ (mapcar '- dp2 dp1) (list s s 1)))
(command "pline" pt1)
(while (< i n)
 (setq pb (nth i libp))
 (setq ds (+ (distance pa pb) ds))
 (setq p (mapcar '* s (list ds ds 1)))
 (setq p (mapcar '+ p dp1))
 (setq p (mapcar '+ p pb))
 (command p)
 (setq i (1+ i))
 (setq pa pb)
) ; while
(command "")
(command "pedit" (entlast) "F" "")
(setq j (1+ j))
 )
) ; if progn
 ) ; while (< j m)
) ; defun gd5ratea1

(defun gd5ratea2 (en pc p0 lib k lid / i n lib1 p libp en2 st ps)
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq p (gd5scale p0 pc (cadr lib1) (caddr lib1)))
(command "copy" en "" p0 p)
(setq en2 (entlast))
(setq libp (arc_to_pline en2))
(entdel en2)
(setq ps (nth k lib1))
(setq libp (gd5scalib libp p (car ps) (cadr ps)))
(drawlib libp)
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5ratea2

(defun gd5rate0 (en pc lib lid idch libmsnt libch libd
 libe / i n lib1 libp check libpp r
 k lb d1 d2 d3 ent
)
 (if (= (boole 1 (cdr (assoc 70 (entget en))) 2) 2)
(setq check 1)
(if (> (abs (cdr (assoc 42 (entget (entnext en))))) 0.00001)
 (setq check 1)
 (setq check nil)
) ; if
 ) ; if
 (setq libp (creatlib en))
 (setq lb (lengthlibp '(0 0 3) libp))
 (if (wcmatch lid "*D@0*")
(progn
 (setq lch (gohead lid "D@0*"))
 (setq lch (substr lch 1 3))
 (setq k (nthlib lch libch))
 (setq libd (assoc en libd))
)
 ) ; (if (wcmatch lid "*D@#*,*E@#*") (progn
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(if (wcmatch lid "*D@#*,*E@#*")
 (setq st (strcat (substr lid 4) "-" st))
 (setq st (strcat lid "-" st))
)
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq libpp (gd5scalib libp pc (cadr lib1) (caddr lib1)))
(drawlib libpp)
(setq ent (entlast))
(if check
 (command "pedit" ent "F" "")
)
(if (wcmatch lid "*D@#*")
 (drawsld en ent libch lib1 lid lb k libd st)
)
(if (wcmatch lid "*E@#*")
 (drawsle ent lb (assoc en libe) st)
)
(if (= idch 0)
 (setq r 1)
 (setq r (car (nth idch lib1)))
)
(drawlibmsnt libmsnt libpp r sts libch libd libe lib1)
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5rate0

(defun drawsle (ent l libd st / libp lb n e d d1 d2 i l1 l2)
 (setq libp (creatlib ent))
 (setq lb (lengthlibp '(0 0 3) libp))
 (setq l1 (car (cadr libd)))
 (setq l2 (* l1 (/ lb l)))
 (setq d2 (- l1 l2))
 (setq d1 (- l1 (car (caddr libd))))
 (setq i (fix (/ d2 d1)))
 (while ( (rem (abs i) 2) 0.5)
 (setq e (caddr libd))
 (setq e (cadr libd))
) ; if (< (rem (abs i) 2) 0.5)
(setq d (- l1 (* i d1)))
(drawsldblock libp d e st)
(setq i (1+ i))
 ) ; while (< i 0)
 (setq i (1+ i))
 (setq n (length libd))
 (while (< i n)
(setq e (nth i libd))
(setq d (car e))
(if (<= d l2)
 (drawsldblock libp d e st)
)
(setq i (1+ i))
 ) ; while (< i n)
) ; defun drawsle(en ent l libd st / libp lb n e d d1 i)

(defun drawsld (en ent libch lib1 lid l k libd st /
libp lb n1 n2 r n e d m j a
nn d1 d2 i check l1
 )
 (setq d2 (car (last libd)))
 (setq libp (creatlib ent))
 (setq lb (lengthlibp '(0 0 3) libp))
 (setq d1 (nth k lib1))
 (setq n1 (fix (car d1)))
 (setq n2 (- (cadr d1)))
 (setq d1 (caddr d1))
 (setq l1 (car (cadr libd)))
 (setq l2 (* l1 (/ lb l)))
 (if (= d1 0)
(setq d1 (- l1 (car (caddr libd))))
 )
 (setq l2 (- l2 (* d2 n2) (* d1 n1)))
 (setq r (/ l2 l1))
 (setq n (length libd))
 (setq i 0)
 (while (< i n1)
(if (= (rem i 2) 1)
 (setq e (cadr libd))
 (setq e (caddr libd))
) ; if (= (rem i 2) 1)
(setq d (+ (* d2 n2) l2 (* d1 (1+ i))))
(drawsldblock libp d e st)
(setq i (1+ i))
 ) ; while (< i n1)
 (if (< n1 0)
(setq i (1+ (- n1)))
(setq i 1)
 )
 (while (< i n)
(setq e (nth i libd))
(setq d (car e))
(setq d (+ (* (car e) r) (* d2 n2)))
(drawsldblock libp d e st)
(setq i (1+ i))
 ) ; while (< i n)
) ; defun drawsld(en ent libch lib1 lid)

(defun drawsldblock
 (libp d e st / m j pa check pb enj p0 da a p1 ss nlid)
 (setq m (length libp)
j 1
pa (car libp)
check 1
 )
 (while (and (< j m) check)
(setq pb (nth j libp))
(if (< (distance pa pb) d)
 (setq d (- d (distance pa pb)))
 (progn
(setq check nil)
(setq p (polar pa (angle pa pb) d))
(setq enj (cadr e)
 p1 (caddr e)
 a (last e)
)
(setq nlid (cdr (assoc 8 (entget enj))))
(setq nlid (strcat (substr lid 4 2) "-"))
(setq p0 (cdr (assoc 10 (entget enj))))
(setq da (- (angle pa pb) a))
(setq p (polar p (+ (angle p1 p0) da) (distance p1 p0)))
(command "copy" enj "" p0 p)
(setq enj (entlast))
(command "rotate" enj "" p (angtos da))
(command "explode" enj)
(setq ss (ssget "P"))
(changelid ss st nlid)
 ) ; progn
) ; (if (> (distance pa pb) d)
(setq pa pb)
(setq j (1+ j))
 ) ;(while (and (< m j) check)
) ; defun drawsldblock(libp d e st / m j pa check pb enj p0 da a p1 ss)

(defun changelid (ss st nlid / n i en lid l)
 (setq l (strlen st))
 (if (> l 3)
(setq st (substr st (- l 2)))
 )
 (setq n (sslength ss)
i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(setq lid (cdr (assoc 8 (entget en))))
(if (null (wcmatch lid "##-*"))
 (setq lid (strcat (substr nlid 1 3) lid))
)
(setq lid (strcat lid "-" st))
(if (null (tblsearch "layer" lid))
 (command "layer" "n" lid "")
)
(command "change" en "" "P" "la" lid "")
(setq i (1+ i))
 ) ;(while (< i n)
) ; defun changelid(ss st / n i en lid)

(defun drawlibmsnt (libmsnt libpp r st libch libd libe
 lib1 / n i lib12 libp m j s
 a d i1 p1 p2 p en lid h sten
 cr l lch k d2 d3 lb libd1
 )
 (setq libmsnt (cdr libmsnt))
 (setq n (length libmsnt)
i 0
 )
 (while (< i n)
(setq lib12 (nth i libmsnt)
 libp '()
)
(setq ens (car lib12))
(setq lib12 (cadr lib12))
(setq lid (cdr (assoc 8 (entget ens))))
(setq lid (substr lid 4))
(if (wcmatch lid "*D@0*")
 (progn
(setq lch (gohead lid "D@0*"))
(setq lch (substr lch 1 3))
(setq k (nthlib lch libch))
(setq libd1 (assoc ens libd))
 )
) ; (if (wcmatch lid "*D@#*,*E@#*") (progn
(if (wcmatch lid "*D@#*,*E@#*")
 (setq cst (strcat (substr lid 4) st))
 (setq cst (strcat lid st))
)
(if (null (tblsearch "layer" cst))
 (command "layer" "n" cst "")
)
(setvar "clayer" cst)
(setq sten (cdr (assoc 0 (entget ens))))
(cond
 ((= sten "POLYLINE")
 (setq lb (lengthlibp '(0 0 3) (creatlib ens)))
 (setq m (length lib12)
 j 0
 )
 (while (< j m)
 (setq l (nth j lib12))
 (setq i1 (car l)
 s (cadr l)
 a (caddr l)
 d (last l)
 )
 (setq p1 (nth i1 libpp)
 p2 (nth (1- i1) libpp)
 )
 (setq p (polar p1 (angle p1 p2) (* (distance p1 p2) s)))
 (setq p (polar p (+ (angle p1 p2) a) (* d r)))
 (setq libp (cons p libp))
 (setq j (1+ j))
 ) ; while (< j m)
 (setq libp (reverse libp))
 (drawlib libp)
 (setq ent (entlast))
 (if (wcmatch lid "*D@#*")
 (drawsld ens ent libch lib1 lid lb k libd1 st)
 )
 (if (wcmatch lid "*E@#*")
 (drawsle ent lb (assoc ens libe) st)
 )
 ) ; (= sten "POLYLINE")
 ((= sten "LINE")
 (setq m (length lib12)
 j 0
 )
 (while (< j m)
 (setq l (nth j lib12))
 (setq i1 (car l)
 s (cadr l)
 a (caddr l)
 d (last l)
 )
 (setq p1 (nth i1 libpp)
 p2 (nth (1- i1) libpp)
 )
 (setq p (polar p1 (angle p1 p2) (* (distance p1 p2) s)))
 (setq p (polar p (+ (angle p1 p2) a) (* d r)))
 (setq libp (cons p libp))
 (setq j (1+ j))
 ) ; while (< j m)
 (command "line" (car libp) (cadr libp) "")
 ) ; ((= sten "LINE")
 ((= sten "ARC")
 (setq m (length lib12)
 j 0
 )
 (while (< j m)
 (setq l (nth j lib12))
 (setq i1 (car l)
 s (cadr l)
 a (caddr l)
 d (last l)
 )
 (setq p1 (nth i1 libpp)
 p2 (nth (1- i1) libpp)
 )
 (setq p (polar p1 (angle p1 p2) (* (distance p1 p2) s)))
 (setq p (polar p (+ (angle p1 p2) a) (* d r)))
 (setq libp (cons p libp))
 (setq j (1+ j))
 ) ; while (< j m)
 (command "arc" (car libp) (cadr libp) (caddr libp))
 ) ; ((= sten "ARC")
 (1
 (setq l (car lib12))
 (setq i1 (car l)
 s (cadr l)
 a (caddr l)
 d (last l)
 )
 (setq p1 (nth i1 libpp)
 p2 (nth (1- i1) libpp)
 )
 (setq p (polar p1 (angle p1 p2) (* (distance p1 p2) s)))
 (setq p (polar p (+ (angle p1 p2) a) (* d r)))
 (cond
 ((= sten "CIRCLE")
 (setq cr (cdr (assoc 40 (entget ens))))
 (command "circle" p cr)
 ) ; (= sten "CIRCLE")
 ((= sten "INSERT")
 (setq stext (cdr (assoc 2 (entget ens))))
 (setq a (cdr (assoc 50 (entget ens))))
 (command "insert" stext p "" "" (angtos a))
 (COMMAND "EXPLODE" (ENTLAST))
 (changelid (ssget "P") lid lid)
 ) ; (= sten "INSERT")
 ((= sten "TEXT")
 (setq h (cdr (assoc 40 (entget ens))))
 (setq textt (cdr (assoc 1 (entget ens))))
 (setq a (cdr (assoc 50 (entget ens))))
 (setq texts (cdr (assoc 7 (entget ens))))
 (command "style" texts "" h "" "" "" "" "")
 (command "text" p (angtos a) textt)
 ) ; (= sten "TEXT")
 ) ; cond
 ) ; 1
) ; cond
(setq i (1+ i))
 ) ; while (< i n)
) ; defun drawlibmsnt(libmsnt libpp r st libch libd libe lib1 / n i lib12 libp m j s a d i1 p1 p2 p en lid h sten cr l lch k d2 d3 lb libd1)

(defun gd5rate1 (en pc p0 lib k lid idch libmsnt libch
 libd libe / libp p1 p2 pt1 pt2 dp1 dp2 n
 i s da pa pb ds m j check sts
 r kd lb d1 d2 d3 ent
)
 (if (= (boole 1 (cdr (assoc 70 (entget en))) 2) 2)
(setq check 1)
(if (> (abs (cdr (assoc 42 (entget (entnext en))))) 0.00001)
 (setq check 1)
 (setq check nil)
) ; if (> (abs (cdr (assoc 42 (entget (entnext en))))) 0.00001)
 ) ; if (= (boole 1 (cdr (assoc 70 (entget en))) 2) 2)
 (setq libp (creatlib en))
 (setq lb (lengthlibp '(0 0 3) libp))
 (if (wcmatch lid "*D@0*")
(progn
 (setq lch (gohead lid "D@0*"))
 (setq lch (substr lch 1 3))
 (setq kd (nthlib lch libch))
 (setq libd (assoc en libd))
)
 ) ; (if (wcmatch lid "*D@#*,*E@#*") (progn
 (setq p1 (car libp))
 (setq p2 (last libp))
 (setq rev nil)
 (if (> (distance p1 p0) (distance p2 p0))
(progn
 (setq libp (reverse libp))
 (setq rev 1)
 (setq p1 (car libp)
 p2 (last libp)
 )
)
 ) ; progn if
 (setq m (length lib)
j 0
 )
 (while (< j m)
(setq lib1 (nth j lib))
(if (= (last lib1) 1)
 (progn
(setq st (fix (* (car lib1) 10)))
(setq st (itoa st))
(if (= (strlen st) 2)
 (setq st (strcat "0" st))
)
(if (> (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(if (wcmatch lid "*D@#*,*E@#*")
 (setq st (strcat (substr lid 4) "-" st))
 (setq st (strcat lid "-" st))
)
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq pt1 (getpt_1 p1 pc p0 lib1 k))
(setq pt2 (gd5scale p2 pc (cadr lib1) (caddr lib1)))
(setq dp1 (mapcar '- pt1 p1))
(setq dp2 (mapcar '- pt2 p2))
(setq n (length libp)
 i 1
)
(setq s (long libp)
 ds 0
 pa (car libp)
)
(setq s (mapcar '/ (mapcar '- dp2 dp1) (list s s 1)))
(command "pline" pt1)
(while (< i n)
 (setq pb (nth i libp))
 (setq ds (+ (distance pa pb) ds))
 (setq p (mapcar '* s (list ds ds 1)))
 (setq p (mapcar '+ p dp1))
 (setq p (mapcar '+ p pb))
 (command p)
 (setq i (1+ i))
 (setq pa pb)
) ; while
(command "")
(setq ent (entlast))
(if check
 (command "pedit" ent "F" "")
)
(if (wcmatch lid "*D@#*")
 (drawsld en ent libch lib1 lid lb kd libd st)
)
(if (wcmatch lid "*E@#*")
 (drawsle ent lb (assoc en libe) st)
)
(if (= idch 0)
 (setq r 1)
 (setq r (car (nth idch lib1)))
)
(setq libpp (creatlib (entlast)))
(if rev
 (setq libpp (reverse libpp))
)
(drawlibmsnt libmsnt libpp r sts libch libd libe lib1)
(setq j (1+ j))
 )
) ; if progn
 ) ; while (< j m)
) ; defun gd5rate1

(defun gd5rate2 (en pc p0 lib k lid idch libmsnt
 libch libd libe / i n lib1 p libp
 en2 check r kd lb d1 d2 d3 ent
 libpd
)
 (if (= (boole 1 (cdr (assoc 70 (entget en))) 2) 2)
(setq check 1)
(if (> (abs (cdr (assoc 42 (entget (entnext en))))) 0.00001)
 (setq check 1)
 (setq check nil)
) ; if (> (abs (cdr (assoc 42 (entget (entnext en))))) 0.00001)
 ) ; if (= (boole 1 (cdr (assoc 70 (entget en))) 2) 2)
 (setq libpd (creatlib en))
 (setq lb (lengthlibp '(0 0 3) libpd))
 (if (wcmatch lid "*D@0*")
(progn
 (setq lch (gohead lid "D@0*"))
 (setq lch (substr lch 1 3))
 (setq kd (nthlib lch libch))
 (setq libd (assoc en libd))
)
 ) ; (if (wcmatch lid "*D@#*,*E@#*") (progn
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(if (wcmatch lid "*D@#*,*E@#*")
 (setq st (strcat (substr lid 4) "-" st))
 (setq st (strcat lid "-" st))
)
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq p (gd5scale p0 pc (cadr lib1) (caddr lib1)))
(command "copy" en "" p0 p)
(setq en2 (entlast))
(setq libp (creatlib en2))
(entdel en2)
(setq ps (nth k lib1))
(setq libp (gd5scalib libp p (car ps) (cadr ps)))
(drawlib libp)
(setq ent (entlast))
(if check
 (command "pedit" ent "F" "")
)
(if (wcmatch lid "*D@#*")
 (drawsld en ent libch lib1 lid lb kd libd st)
)
(if (wcmatch lid "*E@#*")
 (drawsle ent lb (assoc en libe) st)
)
(if (= idch 0)
 (setq r 1)
 (setq r (car (nth idch lib1)))
)
(drawlibmsnt libmsnt libp r sts libch libd libe lib1)
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5rate2

(defun gd5rateL0 (en pc lib lid idch libmsnt
 libch libd libe / i n lib1
 libp check libpp r
 )
 (setq libp (line_to_lib en))
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq libpp (gd5scalib libp pc (cadr lib1) (caddr lib1)))
(command "line" (car libpp) (cadr libpp) "")
(if (= idch 0)
 (setq r 1)
 (setq r (car (nth idch lib1)))
)
(drawlibmsnt libmsnt libpp r sts libch libd libe lib1)
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5rateL0

(defun gd5rateL1 (en pc p0 lib k lid idch libmsnt libch
 libd libe / libp p1 p2 pt1 pt2 dp1 dp2
 n i s da pa pb ds m j check
 )
 (setq libp (line_to_lib en))
 (setq p1 (car lib)
p2 (last libp)
 )
 (if (> (distance p1 p0) (distance p2 p0))
(progn
 (setq libp (reverse libp))
 (setq p1 (car libp)
 p2 (last libp)
 )
)
 ) ; progn if
 (setq m (length lib)
j 0
 )
 (while (< j m)
(setq lib1 (nth j lib))
(if (= (last lib1) 1)
 (progn
(setq st (fix (* (car lib1) 10)))
(setq st (itoa st))
(if (= (strlen st) 2)
 (setq st (strcat "0" st))
)
(if (> (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq pt1 (getpt_1 p1 pc p0 lib1 k))
(setq pt2 (gd5scale p2 pc (cadr lib1) (caddr lib1)))
(setq dp1 (mapcar '- pt1 p1))
(setq dp2 (mapcar '- pt2 p2))
(setq n (length libp)
 i 1
)
(setq s (long libp)
 ds 0
 pa (car libp)
)
(setq s (mapcar '/ (mapcar '- dp2 dp1) (list s s 1)))
(command "pline" pt1)
(while (< i n)
 (setq pb (nth i libp))
 (setq ds (+ (distance pa pb) ds))
 (setq p (mapcar '* s (list ds ds 1)))
 (setq p (mapcar '+ p dp1))
 (setq p (mapcar '+ p pb))
 (command p)
 (setq i (1+ i))
 (setq pa pb)
) ; while
(command "")
(setq libpp (creatlib (entlast)))
(if (= idch 0)
 (setq r 1)
 (setq r (car (nth idch lib1)))
)
(drawlibmsnt libmsnt libpp r sts libch libd libe lib1)
(setq j (1+ j))
 )
) ; if progn
 ) ; while (< j m)
) ; defun gd5rate1

(defun gd5ratel2 (en pc p0 lib k lid idch libmsnt
 libch libd libe / i n lib1 p libp
 en2 check st
 )
 (setq libp (line_to_lib en))
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(setq st (strcat lid "-" st))
(if (null (tblsearch "layer" st))
 (command "layer" "n" st "")
)
(setvar "clayer" st)
(setq p (gd5scale p0 pc (cadr lib1) (caddr lib1)))
(command "copy" en "" p0 p)
(setq en2 (entlast))
(setq libp (line_to_lib en2))
(entdel en2)
(setq ps (nth k lib1))
(setq libp (gd5scalib libp p (car ps) (cadr ps)))
(command "line" (car libp) (cadr libp) "")
(if (= idch 0)
 (setq r 1)
 (setq r (car (nth idch lib1)))
)
(drawlibmsnt libmsnt libp r sts libch libd libe lib1)
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5ratel2

(defun line_to_lib (en / p1 p2)
 (setq p1 (cdr (assoc 10 (entget en))))
 (setq p2 (cdr (assoc 11 (entget en))))
 (list p1 p2)
) ; (defun line_to_lib(en)

(defun cir_to_pline (en / pc r da i n libp)
 (setq pc (cdr (assoc 10 (entget en))))
 (setq r (cdr (assoc 40 (entget en))))
 (setq da (/ pi 8)
n 16
i 0
libp '()
 )
 (while (<= i n)
(setq libp (cons (polar pc (* da i) r) libp))
(setq i (1+ i))
 ) ; while
 (reverse libp)
) ; defun cir_to_pline(en / pc r da i n libp)

(defun nep (p libp / pi2 n i p1 pn p2 pp)
 (setq pi2 (* pi 0.5))
 (setq n (length libp)
i 1
p1 (car libp)
 )
 (setq pn p1)
 (while (< i n)
(setq p2 (nth i libp))
(setq pp (polar p (+ (angle p1 p2) pi2) 1))
(setq pp (inters p1 p2 p pp nil))
(if (null (inters p pp p1 p2))
 (if (< (distance p p1) (distance p p2))
(setq pp p1)
(setq pp p2)
 )
) ; if
(if (< (distance p pp) (distance p pn))
 (setq pn pp)
)
(setq p1 p2)
(setq i (1+ i))
 ) ; while
 (GRDRAW PN P 2)
 (setq pn pn)
) ; defun nep(p libp / pi2 n i p1 pn p2 pp)

(defun ofs2 (en lid / libp p1 p2 p3 d a en1)
 (setq libp (creatlib en))
 (setq p2 (car libp)
p3 (cadr libp)
 )
 (setq d (* (atof (substr lid 1 4)) 0.1))
 (if (= (getenv "CADUNIT") "IN")
(setq d (/ d 25.4))
 )
 (if (= "A" (substr lid 5 1))
(setq a (* pi 0.5))
(setq a (* pi -0.5))
 ) ; if (= "A" (substr lid 5 1))
 (setq p1 (polar p2 (+ (angle p2 p3) a) d))
 (command "offset" d (list en p2) p1 "")
 (setq en1 (entlast))
 (setq lid (substr lid 7))
 (if (null (tblsearch "layer" lid))
(command "layer" "n" lid "")
 )
 (command "change" en1 "" "P" "la" lid "")
 (entdel en)
) ; defun ofs2()

(defun gd5rateo (en pc lib lid / check libp i n lib1 st sts libpp)
 (if (= (boole 1 (cdr (assoc 70 (entget en))) 2) 2)
(setq check 1)
(if (> (abs (cdr (assoc 42 (entget (entnext en))))) 0.00001)
 (setq check 1)
 (setq check nil)
) ; if
 ) ; if
 (setq libp (creatlib en))
 (setq i 0
n (length lib)
 )
 (while ( (strlen st) 3)
 (setq st (substr st 1 3))
)
(setq sts (strcat "-" st))
(setq st (strcat lid "-" st))
(setq libpp (gd5scalib libp pc (cadr lib1) (caddr lib1)))
(drawlib libpp)
(if check
 (command "pedit" (entlast) "F" "")
)
(ofs2 (entlast) st)
 )
) ; if
(setq i (1+ i))
 ) ; while
) ; defun gd5rateo(en pc lib lid / check libp i n lib1 st sts libpp)

(defun gd5ratelibj (lib libj ss libch pc / en ch lid
 ai k ch1 j lib1 lib2 st sx sy pt
 nlid
 )
 (setq n (sslength ss)
i 0
m (length lib)
 )
 (while (< i n)
(setq en (ssname ss i))
(setq ch (cdr (assoc 2 (entget en))))
(setq nlid (cdr (assoc 8 (entget en))))
(setq ai (cdr (assoc 50 (entget en))))
(setq k (nthlib (substr ch 1 2) libch))
(setq ch1 (substr ch 3))
(setq j 0)
(while (< j m)
 (setq lib1 (nth j libj))
 (if (= (nth k lib1) ch1)
(progn
 (setq lib2 (nth j lib))
 (setq st (fix (* (car lib2) 10)))
 (setq st (itoa st))
 (if (= (strlen st) 2)
 (setq st (strcat "0" st))
 )
 (if (> (strlen st) 3)
 (setq st (substr st 1 3))
 )
 (setq sx (cadr lib2)
sy (caddr lib2)
 )
 (setq pt (cdr (assoc 10 (entget en))))
 (setq pt (gd5scale pt pc sx sy))
 (command "insert" ch pt "" "" (angtos ai))
 (command "explode" (entlast))
 (setq ssk (ssget "P"))
 (setq k2 (sslength ssk)
k1 0
 )
 (while (< k1 k2)
 (setq enk (ssname ssk k1))
 (setq lid (cdr (assoc 8 (entget enk))))
 (if (null (wcmatch lid "##-*"))
 (setq lid (strcat (substr nlid 1 3) lid))
 )
 (setq lid (strcat lid "-" st))
 (if (null (tblsearch "layer" lid))
 (command "layer" "n" lid "")
 )
 (command "change" enk "" "P" "la" lid "")
 (setq k1 (1+ k1))
 ) ; while (< k1 k2)
)
 ) ; (if (= (nth j lib1) ch1) (progn
 (setq j (1+ j))
) ; (while (< j m)
(setq i (1+ i))
 ) ; while (< i n)
) ; (defun gd5ratelibj(lib libj ss libch pc)

(defun delgdd (ss / n i ss0 ss1 ss2 lid ch en libchd de)
 (setq n (sslength ss)
i 0
libchd '()
 )
 (setq ss0 (ssadd)
ss1 (ssadd)
ss2 (ssadd)
 )
 (while (< i n)
(setq en (ssname ss i))
(setq lid (cdr (assoc 8 (entget en))))
(setq ch (cdr (assoc 0 (entget en))))
(cond
 ((and (wcmatch lid "*D@0*") (= ch "POLYLINE"))
 (setq ss0 (ssadd en ss0))
 (setq ss2 (ssadd en ss2))
 (setq lid (gohead lid "D@0*"))
 (setq st (substr lid 2 1))
 (if (null (member st liblid))
 (setq liblid (cons st liblid))
 )
 (setq lid (substr lid 1 3))
 (setq libchd (cons lid libchd))
 ) ; ((and (wcmatch lid "*D@0*") (= ch "POLYLINE"))
 ((and (wcmatch lid "*E@0*") (= ch "POLYLINE"))
 (setq ss1 (ssadd en ss1))
 (setq ss2 (ssadd en ss2))
 ) ; ((and (wcmatch lid "*E@0*") (= ch "POLYLINE"))
 ((null (and (wcmatch lid "D@0??,E@0??") (= ch "INSERT")))
 (setq ss2 (ssadd en ss2))
 ) ; ((null (and (wcmatch lid "D@0??,E@0??") (= ch "INSERT")))
) ; cond
(setq i (1+ i))
 ) ; while (< i n)
 (list ss0 ss1 ss2 libchd)
) ; defun delgdd(ss / n i ss0 ss1 ss2 lid ch en libchd)

(defun gdd (ss / libd n i en lid libp check st m j enj p p1 l a libde)
 (setq libd '())
 (setq n (sslength ss)
i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(setq lid (cdr (assoc 8 (entget en))))
(if (and (wcmatch lid "*D@0*,*E@0*")
 (= (cdr (assoc 0 (entget en))) "POLYLINE")
)
 (progn
(setq libp (creatlib en))
(setq lid (gohead lid "D@0*,E@0*"))
(setq lid (strcat (substr lid 1 3) "??"))
(setq ssj (ssget "X" (list (cons 8 lid) '(0 . "INSERT"))))
(setq m (sslength ssj)
 j 0
 libde '()
)
(while (< j m)
 (setq enj (ssname ssj j))
 (setq p (cdr (assoc 10 (entget enj))))
 (setq p1 (nep p libp))
 (setq l (lengthlibp p1 libp))
 (setq i1 (getlibposit p1 libp))
 (setq a (angle (nth (1- i1) libp) (nth i1 libp)))
 (setq libde (cons (list l enj p1 a) libde))
 (setq j (1+ j))
) ; while (< j m)
(setq libde (mo_reorder libde 0))
(setq libde (cons en libde))
(setq libd (cons libde libd))
 )
) ; (if (and (wcmatch lid "*D@0*,*E@0*") (= (cdr (assoc 0 (entget en))) "POLYLINE")) (progn
(setq i (1+ i))
 ) ; while
 (setq libd libd)
) ; defun gdd(ss / libd n i en lid libp check st m j enj p p1 l a libde)

(defun gohead (lid ch / check st)
 (setq check 1)
 (while check
(if (wcmatch lid ch)
 (progn
(setq st (substr lid 2 1))
(if (null (member st liblid))
 (setq liblid (cons st liblid))
)
(setq check nil)
 ) ; progn
 (setq lid (substr lid 2))
) ; (if (wcmatch lid ch)
 ) ; (while check
 (eval lid)
) ; defun gohead

(defun lengthlibp (p lib / n i l p1 p2 check)
 (setq n (length lib)
i 1
l 0
p1 (car lib)
check 1
 )
 (while (and (< i n) check)
(setq p2 (nth i lib))
(if (< (- (+ (distance p p1) (distance p p2)) (distance p1 p2))
 0.001
)
 (setq l (+ (distance p1 p) l)
 check nil
 )
 (progn
(setq l (+ (distance p1 p2) l))
(setq p1 p2)
(setq i (1+ i))
 ) ; progn
) ; (if (< (- (+ (distance p p1) (distance p p2)) (distance p1 p2)) 0.001)
 ) ; (while (< i n)
 (eval l)
) ; defun lengthlibp(p lib / n i l p1 p2 check)

(defun mo_reorder (liblim k / n j i lib dx lib2 dx2 liblim1)
 (setq n (length liblim)
j 0
liblim1 '()
 )
 (while (< j n)
(setq lib (nth j liblim))
(if (member lib liblim1)
 (setq j (1+ j))
 (progn
(setq dx (nth k lib))
(setq i (1+ j))
(while (< i n)
 (setq lib2 (nth i liblim))
 (if (null (member lib2 liblim1))
 (progn
 (setq dx2 (nth k lib2))
 (if (< dx2 dx)
(setq lib lib2
 dx dx2
)
 )
 )
 ) ; progn
 (setq i (1+ i))
) ; while
(setq liblim1 (cons lib liblim1))
(setq j 0)
 ) ; progn
) ; if
 ) ; while
 (setq liblim liblim1)
) ; defun mo_reorder(liblim / n i lib dx lib2 dx2 liblim1)

(defun gd5writelibtext
 (lib libd1 lid / n m i dx dy lib1 ch p j ss x y ch h)
 (setq p (getpoint
 "\nWrite down DCL data? <Enter=No> <Input a point=Yes>:"
 )
 )
 (if p
(progn
 (setq x (car p)
 y (cadr p)
 )
 (if (setq ss (ssget "X" (list (cons 8 lid))))
(progn
 (command "layer" "U" lid "")
 (setq check (getstring "\nDelet old text? Y/N <N>:"))
 (if (wcmatch check "Y*,y*")
 (command "erase" ss "")
 )
)
 ) ; (if (setq ss (ssget "X" (list (cons 8 lid)))) (progn
 (cond
((= (getenv "CADUNIT") "CM") (setq h 0.254))
((= (getenv "CADUNIT") "MM") (setq h 2.54))
(1 (setq h 0.1))
 ) ; cond
 (command "style" "CHINA" "" h "" "" "" "" "")
 (setvar "osmode" 0)
 (if (null (tblsearch "layer" lid))
(command "layer" "n" lid "co" 3 lid "")
 )
 (setvar "clayer" lid)
 (setq m (length libd1)
 j 0
 dy (* h -2.0)
 )
 (while (< j m)
(setq ch (nth j libd1))
(setq p (list x (+ (* dy j) y) 0))
(command "text" p "0" ch)
(setq j (1+ j))
 ) ; while (< j m)
 (setq n (length lib)
 m (length (car lib))
 i 0
 dx (* h 10.0)
 x (+ x dx)
 )
 (while (< i n)
(setq lib1 (nth i lib)
 j 0
)
(while (< j m)
 (setq ch (nth j lib1))
 (setq p (list (+ (* dx i) x) (+ (* dy j) y) 0))
 (command "text" p "0" ch)
 (setq j (1+ j))
) ; while (< j m)
(setq i (1+ i))
 ) ; (while (:"))
 (if (wcmatch ch "Y*,y*")
(progn
 (if (= (getvar "dwgtitled") 1)
 (setq ch (getvar "dwgname"))
 (setq ch (getstring "\nEnter File's name:"))
 ) ; (if (= (getvar "dwgtitled") 1)
 (if (> (strlen ch) 0)
 (command "save" ch)
 )
)
 ) ; (if (wcmatch ch "Y*,y*") (progn
)
 ) ; if p (progn
) ; defun gd5writelibtext(lib libd1 lid / n m i dx dy lib1 ch p j h)

(defun texttolib (lid ss1 / ss lib n i en p ch
 dx dy j m lib0 lib1 lib2 x1 y1 x2
 y2 sst h
 )
 (cond
((= (getenv "CADUNIT") "CM") (setq h 0.254))
((= (getenv "CADUNIT") "MM") (setq h 2.54))
(1 (setq h 0.1))
 ) ; cond
 (setq lib '()
dx (* h 10.0)
dy (* h -2.0)
lib0 '()
 )
 (setq ss (ssget "X" (list (cons 8 lid) (cons 0 "TEXT"))))
 (if (and ss ss1)
(setq ss (ssbooleand ss ss1))
(setq ss nil)
 )
 (if ss
(progn
 (setq sst ss)
 (setq n (sslength ss)
 i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(setq ch (cdr (assoc 1 (entget en))))
(if (wcmatch ch "D@##*,d@##*")
 (setq sst (ssdel en sst))
)
(setq i (1+ i))
 ) ; while (< i n)
 (setq ss sst)
 (setq n (sslength ss)
 i 0
 )
 (setq en (ssname ss 0))
 (setq p (cdr (assoc 10 (entget en))))
 (setq x1 (car p)
 y1 (cadr p)
 )
 (setq x2 (car p)
 y2 (cadr p)
 )
 (while ( (car p) x2)
 (setq x2 (car p))
)
(if (> (cadr p) y2)
 (setq y2 (cadr p))
)
(setq i (1+ i))
 ) ; while
 (setq lib (digitlib lib x1 y2 dx dy))
 (setq n (1+ (fix (/ (- (+ x2 (* h 5.0)) x1) dx)))
 j 0
 check 1
 )
 (while check
(setq p (list 0 j))
(if (setq lib2 (assoc p lib))
 (setq j (1+ j)
lib1 (cons (cadr lib2) lib1)
 )
 (setq check nil)
) ; (if (setq lib2 (assoc p lib))
 ) ; (while check
 (setq lib0 (cons (reverse lib1) lib0))
 (setq y1 (get_y1 lib x1 y2))
 (setq m (1+ (fix (/ (- y1 h y2) dy)))
 i 1
 )
 (while (< i n)
(setq j 0
 lib1 '()
)
(while (< j m)
 (setq p (list i j))
 (if (setq lib2 (assoc p lib))
 (setq lib1 (cons (cadr lib2) lib1))
 (setq lib1 (cons "" lib1))
 ) ; if (setq lib2 (assoc p lib))
 (setq j (1+ j))
) ; (while (< j m)
(setq lib0 (cons (reverse lib1) lib0))
(setq i (1+ i))
 ) ; (whie (< i n)
)
 ) ; (if ss (progn
 (reverse lib0)
) ; defun texttolib(lid / ss lib n i en p ch dx dy j m lib0 lib1 lib2 x1 y1 x2 y2)

(defun get_y1 (lib x1 y1 / n i p y)
 (setq n (length lib)
i 0
 )
 (while (< i n)
(setq p (car (nth i lib)))
(if (/= (car p) x1)
 (progn
(setq y (cadr p))
(if (< y y1)
 (setq y1 y)
)
 )
) ; (if (/= (car p) x1) (progn
(setq i (1+ i))
 ) ; (while (< i n)
 (eval y1)
) ; defun get_y2(lib x1 y1 / n i p y)

(defun ssbooleand (ss ss1 / n i ss2 en)
 (setq n (sslength ss)
i 0
ss2 (ssadd)
 )
 (while (< i n)
(setq en (ssname ss i))
(if (ssmemb en ss1)
 (setq ss2 (ssadd en ss2))
)
(setq i (1+ i))
 ) ; (while (< i n)
 (eval ss2)
) ; defun ssbooleand(ss ss1 / n i ss2 en)

(defun ssboolecut (ss ss1 / n i en)
 (if ss1
(progn

 (setq n (sslength ss1)
 i 0
 )
 (while (< i n)
(setq en (ssname ss1 i))
(if (ssmemb en ss)
 (setq ss (ssdel en ss))
)
(setq i (1+ i))
 ) ; (while (< i n)
)
 ) ; (if ss1 (progn
 (eval ss)
) ; defun ssboolecut(ss ss1 / n i en)

(defun ssbooleor (ss ss1 / n i en)
 (setq n (sslength ss)
i 0
 )
 (while (< i n)
(setq en (ssname ss i))
(if (null (ssmemb en ss1))
 (setq ss1 (ssadd en ss1))
)
(setq i (1+ i))
 ) ; (while (< i n)
 (eval ss1)
) ; defun ssbooleor(ss ss1 / n i en)

(defun ssboolexor (ss ss1 / n i ss2 en)
 (setq n (sslength ss)
i 0
ss2 (ssadd)
 )
 (while (< i n)
(setq en (ssname ss i))
(if (null (ssmemb en ss1))
 (setq ss2 (ssadd en ss2))
)
(setq i (1+ i))
 ) ; (while (< i n)
 (setq n (sslength ss1)
i 0
 )
 (while (< i n)
(setq en (ssname ss1 i))
(if (null (ssmemb en ss))
 (setq ss2 (ssadd en ss2))
)
(setq i (1+ i))
 ) ; (while (< i n)
 (eval ss2)
) ; defun ssboolexor(ss ss1 / n i ss2 en)

(defun digitlib (lib x1 y2 dx dy / n i lib1 p nx ny lib2 lib3)
 (setq n (length lib)
i 0
lib3 '()
 )
 (while (< i n)
(setq lib1 (nth i lib))
(setq p (car lib1))
(setq nx (fix (+ (/ (- (car p) x1) dx) 0.5)))
(setq ny (fix (+ (/ (- (cadr p) y2) dy) 0.5)))
(setq lib2 (list (list nx ny) (cadr lib1)))
(setq lib3 (cons lib2 lib3))
(setq i (1+ i))
 ) ; (while (< i n)
 (setq lib3 lib3)
)
[/php]

fsxm · 发表于 2006-10-7 07:57:16

longhu 老兄你的是个什么程序啊?也太大的吓人了吧~88.65 KB不敢下载~
就是把我用过的程序加起来也不够这个份量啦~

雨箭风刀 · 发表于 2006-10-7 12:25:43

这个程序是干什么的?

账号		自动登录	找回密码
密码			立即注册

[LISP函数]：请高人指点函数升级问题

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子