自动画单代号计划管理网络图

wrf610051

;;发一个自动画单代号网络图的程序，没有验证其正确性，大家可以帮忙验证一下


;;===========
;;例1. 逻辑关系表
;;编号               10        20     30     40     50      60       70
;;工作                A         B      C     D      E       G         H
;;工期                1         3      1     6      2       4         2
;;紧前工作           C,D      E,H      -     -      -      D,H        -
;;紧前工作(编号)  (30 40)  (50 70)    nil   nil    nil   (40 70)      nil
(setq bhlst '(10 20 30 40 50 60 70))
(setq gzlst '("A" "B" "C" "D" "E" "G" "H"))
(setq gqlst '(1 3 1 6 2 4 2))
(setq jqgzlst '((30 40)(50 70) nil nil nil (40 70) nil))
;(drawddhwlt bhlst gzlst gqlst jqgzlst)


(defun c:cdyddhgzcsk(/ ES EF LS LF TF FF aflags_old )
   (setvar "attdia" 0)
   (command "osmode" "0")      
   (setvar "cmdecho" 1)
   
   (command "layer" "s" "0" "")  
   
   (command "style" "wrf" "arial.ttf" "0" "1.0" "0" "N" "N")
        (command "line" "-0.9,0.4" "0.9,0.4" "")
        (command "line" "-0.9,-0.4" "0.9,-0.4" "")
        (command "circle" "0,0" "D" "2.0")
       
        (setq BH "编号")
        (setq MC "工作名称")
        (setq GQ "工期")
       
        (setq ES "最早开始")
        (setq EF "最早完成")
        (setq LS "最迟开始")
        (setq LF "最迟完成")
        (setq TF "工作总时差")
        (setq FF "工作自由时差")

        (setq aflags_old (getvar "aflags"))   
       
       
       
        (setq aflags_old (getvar "aflags"))   
        (setvar "aflags" 0)   
       
        (command "attdef" "" "BH" "编号" BH "s" "wrf" "J" "MC" "0,0.7" "0.4" "0")
        (command "attdef" "" "MC" "编号" MC "s" "wrf" "J" "MC" "0,0" "0.4" "0")
        (command "attdef" "" "GQ" "编号" GQ "s" "wrf" "J" "MC" "0,-0.7" "0.4" "0")
        (command "attdef" "" "ES" "最早开始" ES "s" "wrf" "J" "MC" "-1,1.2" "0.4" "0")
        (command "attdef" "" "EF" "最早完成" EF "s" "wrf" "J" "MC" "1,1.2" "0.4" "0")
        (command "attdef" "" "LS" "最迟开始" LS "s" "wrf" "J" "MC" "-1,-1.2" "0.4" "0")
        (command "attdef" "" "LF" "最迟完成" LF "s" "wrf" "J" "MC" "1,-1.2" "0.4" "0")
        (command "attdef" "" "TF" "工作总时差" TF "s" "wrf" "J" "MC" "0,1.2" "0.4" "0")
        (command "attdef" "" "FF" "工作自由时差" FF "s" "wrf" "J" "MC" "0,-1.2" "0.4" "0")
        (setvar "aflags" aflags_old)   
)
(defun drawddhwlt ( bhlst gzlst gqlst jqgzlst /  path kname ll jtlst ljgzlst ptlst pt0lst
                                        ESlst EFlst TFlst LSlst FFlst LAGlst gjglst gjxllst
                                        l term fromto val ang0
                                        n bh
                                        BSstr GZstr GQstr ESstr EFstr LSstr LFstr TFstr FFstr
                                        pti gjptlst entname1
                                        )
       
       
        (command "erase" "all" "")
        (c:cdyddhgzcsk)
        (setq path (getvar "SAVEFILEPATH"))
        (setq kname (strcat path "ddhgzcsk"))
       
        (if (findfile (strcat kname ".dwg"))
                (command "wblock" kname "y" "*")
                (command "wblock" kname "*")
        )
        (command "insert" kname "0,0" "1.0" "1.0" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
    (command "erase" "all" "")
        (vl-file-delete (strcat kname ".dwg"))
       
        (setq l (ghjcb bhlst gzlst gqlst jqgzlst))
        (setq bhlst (nth 0 l))
        (setq gzlst (nth 1 l))
        (setq gqlst (nth 2 l))
        (setq jqgzlst (nth 3 l))
       
        (setq ll (getgxlst bhlst gzlst gqlst jqgzlst))
        (setq jtlst (car ll))
        (setq ljgxlst (cadr ll))
        (setq ll (ddhwltbd bhlst gzlst jtlst))
        (setq ptlst (car ll))
        (setq pt0lst (cadr ll))
        (setq ll (ddhsjcsjs ljgxlst jtlst))
       
        (setq ESlst (nth 0 ll))
        (setq EFlst (nth 1 ll))
        (setq TFlst (nth 2 ll))
        (setq FFlst (nth 3 ll))
        (setq LSlst (nth 4 ll))
        (setq LFlst (nth 5 ll))
        (setq LAGlst (nth 6 ll))
        (setq gjgzlst (nth 7 ll))
        (setq gjxllst (nth 8 ll))
       
       
        (command "layer" "s" "关键路线" "")
        (setq l LAGlst)
        (while l
                (setq term (car l))
                (setq fromto (car term))
                (setq val (cadr term))
                (setq i (XD:ist:Position fromto jtlst))
                (setq pt0 (car (nth i pt0lst)))
                (setq ang0 (cadr (nth i pt0lst)))
                (command "text" "j" "mc" (polar pt0 (/ pi 2.0) (* 1.0 0.5)) 0.4 ang0 (rtos val))
                (setq l (cdr l))
        )
       
        (command "layer" "s" "工作" "")
        (setq n (length bhlst))
        (setq i -1)
        (while (< i (- n 1))
                (setq i (+ i 1))
                (setq bh (nth i bhlst))
                (setq BHstr (rtos bh))
                (setq GZstr (nth i gzlst))
                (setq GQstr (rtos (nth i gqlst)))
                (setq ESstr (rtos (car (assoc bh ESlst))))
                (setq EFstr (rtos (car (assoc bh EFlst))))
                (setq LSstr (rtos (car (assoc bh LSlst))))
                (setq LFstr (rtos (car (assoc bh LFlst))))
                (setq TFstr (rtos (car (assoc bh TFlst))))
                (setq FFstr (rtos (car (assoc bh FFlst))))
               
               
                (command "insert" "ddhgzcsk" (nth i ptlst) "1.0" "1.0" "0" BHstr GZstr GQstr ESstr EFstr LSstr LFstr TFstr FFstr)
        )
       
        (command "layer" "s" "关键路线" "")
        (setq gjxllst (rgjxllst bhlst gjxllst))
        (setq l gjxllst)
        (while l
                (setq term (car l))
                (setq gjptlst nil)
                (while term
                        (setq bh (car term))
                        (setq i (XD:ist:Position bh bhlst))
                        (setq pti (nth i ptlst))
                        (setq gjptlst (cons pti gjptlst))
                        (setq term (cdr term))
                )
               
                (setq entname1 (XD::PolyLine:Make gjptlst nil))
                (command "change" entname1 "" "p" "c" "1" "")
                (command "pedit" entname1 "w" 0.1 "")
                (setq l (cdr l))
        )
        (command "gridmode" "0")
        gjxllst
)
(defun ghjcb (bhlst gzlst gqlst jqgzlst / l n tailgz i bh ll jqgztail ilst )
        (setq l jqgzlst)
        (setq l (vl-remove-if-not '(lambda (x) (cond ((equal x nil))(T nil))) l))
        (setq n (length l))
        (if (> n 1)
                (progn
                        (setq bhlst (cons 0 bhlst))
                        (setq gzlst (cons "Begin" gzlst))
                        (setq gqlst (cons 0 gqlst))
                        (setq jqgzlst (SubstItem '(0) nil jqgzlst))
                        (setq jqgzlst (cons nil jqgzlst))
                )
        )
       
        (setq tailgz nil)
        (setq i -1)
        (repeat (length bhlst)
                (setq i (+ i 1))
                (setq bh (nth i bhlst))
                (setq ll (vl-remove-if-not '(lambda (x) (cond ((member bh x))(T nil))) jqgzlst))
                (if (equal ll nil)
                        (setq tailgz (cons (list i bh) tailgz))
                )
        )
        (setq tailgz (reverse tailgz))
        (setq jqgztail (mapcar '(lambda (x) (cadr x)) tailgz))
        (setq n (length tailgz))
        (if (> n 1)
                (progn
                        (setq bhlst (reverse (cons 9999 (reverse bhlst))))
                        (setq gzlst (reverse (cons "End" (reverse gzlst))))
                        (setq gqlst (reverse (cons 0 (reverse gqlst))))
                        (setq jqgzlst (reverse (cons jqgztail (reverse jqgzlst))))
                )
        )
       
       
       
        (setq ilst (getjqgzilst bhlst jqgzlst))
        (setq bhlst (mapcar '(lambda (x) (nth x bhlst)) ilst))
        (setq gzlst (mapcar '(lambda (x) (nth x gzlst)) ilst))
        (setq gqlst (mapcar '(lambda (x) (nth x gqlst)) ilst))
        (setq jqgzlst (mapcar '(lambda (x) (nth x jqgzlst)) ilst))
       
        (list bhlst gzlst gqlst jqgzlst)
)
(defun getjqgzilst ( bhlst jqgzlst / ypxilst ypxbhlst wpxilst kpxbhlst ll l )
        (setq ypxilst nil)
        (setq ypxbhlst nil)
        (setq wpxilst (cons 0 (createlstn (- (length bhlst) 1))))
        (setq kpxbhlst (list nil))
        (while wpxilst
                (setq ll (mapcar '(lambda (x) (cond ((isallmember x kpxbhlst) 1)(T 0))) jqgzlst))
                (setq l (mapcar '(lambda (x y) (cond ((= x 1) y)(T -1))) ll bhlst))
                (setq ypxbhlst_all (vl-remove-if '(lambda (x) (cond ((equal x -1))(T nil))) l))
                (setq ypxbhlst_new (movelst ypxbhlst ypxbhlst_all))
                (setq ypxbhlst (append ypxbhlst ypxbhlst_new))
                (setq ypxilst (mapcar '(lambda (x) (XD:ist:Position x bhlst)) ypxbhlst))
                (setq kpxbhlst (mapcar '(lambda (x) (nth x bhlst)) ypxilst))
                (setq wpxilst (movelst ypxilst wpxilst))
        )
        (setq l ypxilst)
)
(defun isallmember ( lst1 lst2 / l )
        (setq l (vl-remove-if '(lambda (x) (cond ((member x lst2))(T nil))) lst1))
        (if (equal l nil)
                T
                nil
        )
)
(defun movelst ( lst1 lst2 / item )
        (while lst1
                (setq item (car lst1))
                (if (member item lst2)
                        (setq lst2 (XD:ist:RemoveE1 item lst2))
                )
                (setq lst1 (cdr lst1))
        )
        lst2
)
(defun getgxlst (bhlst gzlst gqlst jqgzlst / l ljgxlst jtlst i No1 ilst ii No2 term gx )
        (setq l bhlst)
        (setq ljgxlst nil)
        (setq jtlst nil)
        (setq i -1)
        (while l
                (setq i (+ i 1))
                (setq No1 (car l))
               
                (setq ilst (getilst No1 jqgzlst))
                (while ilst
                        (setq ii (car ilst))
                        (setq No2 (nth ii bhlst))
                        (setq jtlst (cons (list No1 No2) jtlst))
                        (setq ilst (cdr ilst))
                )
               
                (setq term (nth i jqgzlst))
                (setq gx (list No1
                                                        (list (nth i gzlst)
                                                                        (nth i gqlst)
                                                                        term)))
                (setq ljgxlst (cons gx ljgxlst))
                (setq l (cdr l))
        )
        (list (reverse jtlst) (reverse ljgxlst))
)
(defun getilst ( No jqgzlst / l i ilst term )
        (setq l jqgzlst)
        (setq i -1)
        (setq ilst nil)
        (while l
                (setq i (+ i 1))
                (setq term (car l))
                (if (member No term)
                        (setq ilst (cons i ilst))
                )
                (setq l (cdr l))
        )
        (setq ilst (reverse ilst))
)
(defun ddhwltbd ( bhlst gzlst jtlst / cl n ptlst i gzm angi pti
                                                l pt0lst term No1 No2 j pt1 pt2
                                                ename ent a aa dis pt3 pt4 ent1 ent2 pt5 pt6
                                                pt0 ang0
                                                )
        (setvar "attdia" 0)
        (command "osmode" "0")
        (setvar "cmdecho" 1)
        (setvar "attreq" 1)
        (command "style" "wrf" "ARial.ttf" "0" "1.0" "0" "N" "N")
       
        (command "gridunit" "1,1")
        (command "gridmode" "1")
       
        (setq cl (getvar "clayer"))
        (command "layer" "n" "工作,逻辑关系连线,节点,节点时间参数,关键路线" "")
       
        (command "layer" "c" "blue" "工作"
                                   "c" "green" "逻辑关系连线"
                                   "c" "magenta" "节点"
                                   "c" "magenta" "节点时间参数"
                                   "c" "red" "关键路线"
                                                                          "")
       
       
        (command "layer" "s" "节点" "")
        (command "zoom" "-5,-15" "35,15")
        (setq ptlst (createptlst bhlst))
       
        (setq ptlst (tjptlst bhlst ptlst jtlst))
        (mapcar '(lambda (x) (command "circle" x "1.0")) ptlst)
       
        (command "layer" "s" "逻辑关系连线" "")
        (setq l jtlst)
        (setq pt0lst nil)
        (command "osmode" "0")
        (while l
                (setq term (car l))
                (setq No1 (car term))
                (setq No2 (cadr term))
                (setq i (XD:ist:Position No1 bhlst))
                (setq j (XD:ist:Position No2 bhlst))
                (setq pt1 (nth i ptlst))
                (setq pt2 (nth j ptlst))
               
                (entmake (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2) '(8 . "逻辑关系连线")))
                (setq ename (entlast))
               
                (setq ent (entget ename))
                (setq pt1 (cdr (assoc 10 ent)))
                (setq pt2 (cdr (assoc 11 ent)))
                (setq a (angle (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
                (setq aa (+ a pi))
                (setq dis -1)
                (setq pt3 (polar pt1 aa dis))
                (setq pt4 (polar pt2 a dis))
                (setq ent1 (subst (cons 10 pt3) (assoc 10 ent) ent))
                (setq ent2 (subst (cons 11 pt4) (assoc 11 ent1) ent1))
                (entmod ent2)
               
               
                (setq pt5 (polar pt4 (+ a -0.22) dis))
                (setq pt6 (polar pt4 (+ a 0.22) dis))
                (command "line" pt4 pt5 pt6 "c")
               
               
                (setq pt0 (list (/ (+ (car pt1) (car pt2)) 2.0) (/ (+ (cadr pt1) (cadr pt2)) 2.0) 0))
                (setq ang0 (* (/ a pi) 180))
                (setq pt0lst (cons (list pt0 ang0) pt0lst))
               
               
                (setq l (cdr l))
        )
        (list ptlst (reverse pt0lst))
)
(defun createptlst ( bhlst / n ptlst i x y pti )
        (setq n (length bhlst))
        (setq ptlst nil)
        (setq ptlst (cons '(0 0 0) ptlst))
        (setq i 0)
        (while(< i (- n 1))
                (setq i (+ i 1))
                (setq x (/ (+ i 1) 2))
                (if (equal (mod i 2) 0)
                        (setq y -1)
                        (setq y 1)
                )
                (setq pti (list (* x 5) (* y 5) 0))
                (setq ptlst (cons pti ptlst))
        )
        (setq ptlst (reverse ptlst))
)
(defun tjptlst ( bhlst ptlst jtlst / pts0 pt x y z pt_new)
        (cond        ((equal (retpts0 bhlst ptlst jtlst) nil)
                                ptlst)
                        (T
                                (setq pts0 (retpts0 bhlst ptlst jtlst))
                                (while pts0
                                        (setq pt (car pts0))
                                        (setq x (car pt))
                                        (setq y (cadr pt))
                                        (setq z (caddr pt))
                                        (if (> y 0)
                                                (setq y (+ y 1))
                                                (setq y (- y 1))
                                        )
                                        (setq pt_new (list x y z))
                                        (setq ptlst (SubstItem pt_new pt ptlst))
                                        (setq pts0 (cdr pts0))
                                )
                                (tjptlst bhlst ptlst jtlst))
        )
)
(defun retpts0 ( bhlst ptlst jtlst / ll pts0 item pt1 pt2 rectan1 pt l )
        (setq ll (mapcar '(lambda (x) (list (XD:ist:Position (car x) bhlst)
                                                                                (XD:ist:Position (cadr x) bhlst)
                                                                                )) jtlst))
        (setq ll (mapcar '(lambda (x) (list (nth (car x) ptlst) (nth (cadr x) ptlst))) ll))        (setq pts0 nil)
        (while ll
                (setq item (car ll))
                (setq pt1 (car item))
                (setq pt2 (cadr item))
                (setq rectan1 (line2rectan (list pt1 pt2) 0.5))
                (setq l ptlst)
                (while l
                        (setq pt (car l))
                        (cond        ((equal pt pt1)
                                                nil)
                                        ((equal pt pt2)
                                                nil)
                                        ((XD::Pnt:IsInside pt rectan1)
                                                (setq pts0 (cons pt pts0)))
                                        (T
                                                nil)
                        )                       
                        (setq l (cdr l))
                )
                (setq ll (cdr ll))
        )
        (setq pts0 (reverse pts0))
)
(defun line2rectan ( line w / pt1 pt2 a pt3 pt4 pt5 pt6 rectan1 )
       
        (setq pt1 (car line))
        (setq pt2 (cadr line))
        (setq a (angle pt1 pt2))
        (setq pt3 (polar pt1 (- a (/ pi 2.0)) (/ w 2.0)))
        (setq pt4 (polar pt1 (+ a (/ pi 2.0)) (/ w 2.0)))
        (setq pt5 (polar pt2 (+ a (/ pi 2.0)) (/ w 2.0)))
        (setq pt6 (polar pt2 (- a (/ pi 2.0)) (/ w 2.0)))
       
       
       
        (setq rectan1 (list pt3 pt4 pt5 pt6 pt3))
)
(defun ddhsjcsjs ( ljgxlst jtlst / bhlst gzmlst gqlst jqgzlst
                                                l1 ESlst EFlst gzbh i l ESi EFi ll l2
                                                term EF LAGlst LAGij TFlst n TFi j
                                                TFj FFlst FFi LSlst LFlst gjgzlst
                                                )
        (setq bhlst (mapcar '(lambda (x) (car x)) ljgxlst))
        (setq gzmlst (mapcar '(lambda (x) (car (cadr x))) ljgxlst))
        (setq gqlst (mapcar '(lambda (x) (cadr (cadr x))) ljgxlst))
        (setq jqgzlst (mapcar '(lambda (x) (caddr (cadr x))) ljgxlst))
       
        (setq l1 bhlst)
        (setq ESlst nil)
        (setq EFlst nil)
        (while l1
                (setq gzbh (car l1))
                (setq i (XD:ist:Position gzbh bhlst))
                (setq l (vl-remove-if-not '(lambda (x) (cond ((equal (cadr x) gzbh))(T nil))) jtlst))
                (cond ((equal l nil)
                                        (setq ESi 0)
                                        (setq EFi (+ ESi (nth i gqlst)))
                                        )
                                ((equal (length l) 1)
                                        (setq ESi (car (cdr (assoc (car (car l)) EFlst))))
                                        (setq EFi (+ ESi (nth i gqlst)))
                                        )
                                ((> (length l) 1)
                                        (setq ll nil)
                                        (setq l2 l)
                                        (while l2
                                                (setq term (car l2))
                                                (setq EF (car (cdr (assoc (car term) EFlst))))
                                                (setq ll (cons EF ll))
                                                (setq l2 (cdr l2))
                                        )
                                        (setq ESi (car (vl-sort ll '>)))
                                        (setq EFi (+ ESi (nth i gqlst)))
                                        )
                )
                (setq ESlst (cons (list (nth i bhlst) ESi) ESlst))
                (setq EFlst (cons (list (nth i bhlst) EFi) EFlst))
                (setq l1 (cdr l1))
        )
        (setq ESlst (reverse ESlst))
        (setq EFlst (reverse EFlst))
       
        (setq l jtlst)
        (setq LAGlst nil)
        (while l
                (setq term (car l))
                (setq EFi (cadr (assoc (car term) EFlst)))
                (setq ESj (cadr (assoc (cadr term) ESlst)))
                (setq LAGij (- ESj EFi))
                (setq LAGlst (cons (list term LAGij) LAGlst))
                (setq l (cdr l))
        )
        (setq LAGlst (reverse LAGlst))
       
        (setq l1 (reverse bhlst))
        (setq TFlst nil)
        (setq n (car l1))
        (setq TFi 0)
        (setq TFlst (cons (list n TFi) TFlst))
        (setq l1 (cdr l1))
        (while l1
                (setq gzbh (car l1))
                (setq l (vl-remove-if-not '(lambda (x) (cond ((equal (car x) gzbh))(T nil))) jtlst))
                (cond ((equal l nil)
                                                (setq TFi 0)
                                                (setq EFi (+ ESi (nth i gqlst)))
                                                )
                                ((equal (length l) 1)
                                                (setq term (car l))
                                                (setq i (XD:ist:Position (car term) bhlst))
                                                (setq j (XD:ist:Position (cadr term) bhlst))
                                                (setq TFj (car (cdr (assoc (cadr term) TFlst))))
                                                (setq LAGij (assoc (list (nth i bhlst) (nth j bhlst)) LAGlst))
                                                (setq TFi (+ TFj (cadr LAGij)))
                                                )
                                ((> (length l) 1)
                                                (setq ll nil)
                                                (setq l2 l)
                                                (while l2
                                                        (setq term (car l2))
                                                        (setq i (XD:ist:Position (car term) bhlst))
                                                        (setq j (XD:ist:Position (cadr term) bhlst))
                                                        (setq TFj (car (cdr (assoc (cadr term ) TFlst))))
                                                        (setq LAGij (assoc (list (nth i bhlst) (nth j bhlst)) LAGlst))
                                                        (setq TFi (+ TFj (cadr LAGij)))
                                                        (setq ll (cons TFi ll))
                                                        (setq l2 (cdr l2))
                                                )
                                                (setq TFi (car (vl-sort ll '<)))
                                                )
                )
                (setq TFlst (cons (list gzbh TFi) TFlst))
                (setq l1 (cdr l1))
        )
       
       
       
        (setq l1 (reverse bhlst))
        (setq FFlst nil)
        (setq n (car l1))
        (setq FFi 0)
        (setq FFlst (cons (list n FFi) FFlst))
        (setq l1 (cdr l1))
        (while l1
                (setq gzbh (car l1))
                (setq l (vl-remove-if-not '(lambda (x) (cond ((equal (car x) gzbh))(T nil))) jtlst))
                (cond ((equal l nil)
                                                (setq TFi 0)
                                                (setq EFi (+ ESi (nth i gqlst)))
                                                )
                                ((equal (length l) 1)
                                                (setq term (car l))
                                                (setq i (XD:ist:Position (car term) bhlst))
                                                (setq j (XD:ist:Position (cadr term) bhlst))
                                                (setq LAGij (assoc (list (nth i bhlst) (nth j bhlst)) LAGlst))
                                                (setq FFi (cadr LAGij))
                                                )
                                ((> (length l) 1)
                                                (setq ll nil)
                                                (setq l2 l)
                                                (while l2
                                                        (setq term (car l2))
                                                        (setq i (XD:ist:Position (car term) bhlst))
                                                        (setq j (XD:ist:Position (cadr term) bhlst))
                                                        (setq LAGij (assoc (list (nth i bhlst) (nth j bhlst)) LAGlst))
                                                        (setq TFi (+ TFj (cadr LAGij)))
                                                        (setq ll (cons FFi ll))
                                                        (setq l2 (cdr l2))
                                                )
                                                (setq FFi (car (vl-sort ll '<)))
                                                )
                )
                (setq FFlst (cons (list gzbh FFi) FFlst))
                (setq l1 (cdr l1))
        )
       
       
       
       
        (setq LSlst (mapcar '(lambda (x y) (list (car x) (+ (cadr x) (cadr y)))) ESlst TFlst))
       
        (setq LFlst (mapcar '(lambda (x y) (list (car x) (+ (cadr x) (cadr y)))) EFlst TFlst))
       
       
       
        (setq l (vl-remove-if-not '(lambda (x) (cond ((equal (cadr x) 0))(T nil))) TFlst))
        (setq gjglst (mapcar '(lambda (x) (car x)) l))
       
        (setq l (vl-remove-if-not '(lambda (x) (cond ((equal (cadr x) 0))(T nil))) LAGlst))
       
        (setq gjxllst (ddhkdjdlst (car bhlst) LAGlst bhlst))
       
       
        (list ESlst EFlst TFlst FFlst LSlst LFlst LAGlst gjgzlst gjxllst)
)
(defun ddhkdjdlst ( No0 LAGlst bhlst / n linelst )
        (setq n (length bhlst))
        (setq linelst (ddhnextlinelst (list (list No0)) LAGlst))
        (repeat n
                (setq linelst (ddhnextlinelst linelst LAGlst))
        )
)
(defun ddhnextlinelst ( linelst LAGlst / linelst_new line pt l line_new )
        (setq LAGlst (vl-remove-if-not '(lambda (x) (cond ((equal (cadr x) 0))(T nil))) LAGlst))
        (setq linelst_new nil)
        (while linelst
                (setq line (car linelst))
                (setq pt (car (reverse line)))
                (setq l (vl-remove-if-not '(lambda (x) (cond ((equal (car (car x)) pt))(T nil))) LAGlst))
                (setq l (mapcar '(lambda (x) (cadr (car x))) l))
                (if l
                        (progn
                                (setq line_new (mapcar '(lambda (x) (reverse (cons x (reverse line)))) l))
                                (setq linelst_new (append line_new linelst_new))
                        )
                        (progn
                                (setq line_new line)
                                (setq linelst_new (cons line_new linelst_new))
                        )
                )
                (setq linelst (cdr linelst))
        )
        (setq linelst_new (reverse linelst_new))
)
(defun rgjxllst ( bhlst gjxllst / ll line )
        (setq ll nil)
        (while gjxllst
                (setq line (car gjxllst))
                (if (and (equal (car bhlst) (car line))
                                        (equal (car (reverse bhlst)) (car (reverse line)))
                          )
                        (setq ll (cons line ll))
                )
                (setq gjxllst (cdr gjxllst))
        )
        ll
)

;;===================
;函数：SubstItem
;功能：替换表中所有旧项（支持任意嵌套表）
;函数代码：
;;;By xq4u 2011-7-24
(defun SubstItem (newitem olditem lst / x tmplst)
  (foreach x (Subst newitem olditem lst)
    (if (listp x)
      (setq tmplst (append tmplst (list (SubstItem newitem olditem x))))
      (setq tmplst (append tmplst (list x)))
    )
  )
  tmplst
)
;语法：
;(SubstItem newitem olditem lst)
;参数：
;newitem:要替换到的内容
;olditem:被查找的内容
;lst:要替换的表
;返回值：
;返回修改后所得的表
;说明：在表中搜索某旧项，并将表中出现的每一个旧项用新项代替，然后返回修改后所得的表（支持任意嵌套表）

(defun createlstn ( n / lst)
        (while (> n 0)
                (setq lst (cons n lst))
                (setq n (- n 1))
        )
        lst
)

(defun XD:ist:Position (val lst / i tf tol)
  (setq tol (car (xdrx_document_getprec)))
  (setq i 0
        tf t
  )
  (while (and
           tf
           (car lst)
         )
    (if (equal (car lst) val tol)
      (setq tf nil)
      (setq i (1+ i))
    )
    (setq lst (cdr lst))
  )
  (if (not tf)
    i
  )
)

wrf610051

我不知道图片如何弄上去。

渠辉

缺
XD:nt:IsInside
XD:ist:RemoveE1
XD:olyLine:Make

wrf610051

渠辉 发表于 2021-10-5 15:13
缺
XD:nt:IsInside
XD:ist:RemoveE1

;;http://bbs.xdcad.net/forum.php?m ... %3D221%26sortid%3D1
(defun XD::Pnt:IsInside (pt pts / an total x)
  (setq pts (XD:ist:SnakePair (XD::PnTs:Close pts))
        total 0.0
  )
  (mapcar
    '(lambda (x)
       (setq an (- (angle pt (car x)) (angle pt (cadr x))))
       (cond
         ((> an pi)
           (setq an (- an pi))
         )
         ((< an (* -1 pi))
           (setq an (+ an pi))
         )
       )
       (setq total (+ total an))
     )
    pts
  )
  (if (equal (- (abs total) pi) 0.0 1e-5)
    t
    nil
  )
)


;;http://bbs.xdcad.net/forum.php?m ... %3D210%26sortid%3D1
(defun XD:ist:RemoveE1(item lst)
   (append (reverse (cdr (member item (reverse lst))))(cdr (member item lst)))
)

;;http://bbs.xdcad.net/forum.php?m ... A%D6%BE%B4%B4%BD%A8
(defun XD::PolyLine:Make (pts IsClosed / flag)
  (if IsClosed
    (setq flag 1)
    (setq flag 0)
  )

  (entmakeX
    (append
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        (cons 90 (length pts))
        (cons 70 flag)
      )
      (mapcar
        (function
          (lambda (x)
            (cons 10 (list (car x) (cadr x)))
          )
        )
        pts
      )
    )
  )
)

mokson

XD,代表要安装晓东工具箱。

Atsai

有些字会变成『表情符号』，已搞定了，谢谢啦！

技术工作室

下载学习，顶一个