|
|
发表于 2011-11-6 15:55
|
显示全部楼层
来自： 马来西亚
原本想静下心来根据黄浩主编的<船体工艺手册>将原有的外板展开法(统一测地线法)更改为该书P437页所述的定线法.可是由于工作的变动,一时静不下心来....
原"统一测地线法"也就是根据新版的<船体建造工艺学>中介绍的步骤进行编制,为了感谢朋友们的回复,现将本人写的代码复制下来..有兴趣者可以复制到文本文件中保存为**.LIPS 然后CAD中调用即可
附原代码:
(defun lgsc (CUR P1 P2 / lgs1);求肋骨实长
(setq lgs1(abs (- (vlax-curve-getDistAtPoint cur p2)
(vlax-curve-getDistAtPoint cur p1)))
)
)
(defun TEST (PL1 PL2 / IPTS PTS);求交点
(setq IPTS (vla-intersectwith
(vlax-ename->vla-object PL1)
(vlax-ename->vla-object PL2)
acExtendNone ;Does not extend either object
)
IPTS (vlax-variant-value IPTS)
)
(if (> (vlax-safearray-get-u-bound IPTS 1) 0)
(progn (setq IPTS
(vlax-safearray->list IPTS)
)
(while (> (length IPTS) 0)
(setq PTS (cons (list (car IPTS)
(cadr IPTS)
(caddr IPTS)
)
PTS
)
IPTS (cdddr IPTS)
)
)
)
)
PTS
)
;计算伸长肋距函数（点1 点2 肋距）
(defun ljsc (lj p1 P2 / lj1)
(setq cz(distance p1 p2)
lj1(sqrt (+ (* cz cz) (* lj lj)))
)
)
;计算肋骨冲势函数（中间肋骨交点 交点 邻近肋骨与十字线交点 ）
(defun lgcs(pt1 pt2 pt3 pt4 lj / pt12 lgcs)
(setq pt12(list (/ (+ (car pt1) (car pt2)) 2)
(/ (+ (cadr pt1) (cadr pt2)) 2)
0)
)
(setq a2(distance pt3 pt4)
a1(distance pt3 pt12)
)
(setq sm(sqrt (+ (* a2 a2) (* lj lj)))
lgcs(/ (* a1 a2) sm)
)
)
; 前端缝线交点（前肋骨端点 肋骨与十字线交点 端缝实长 肋骨实长）
(defun dfjd(pt2 pt1 pl1 pl2 / dfjd)
(setq apla(distance pt2 pt1)
ang1(angle pt2 pt1)
)
(setq a1(- (+ (* pl1 pl1)(* apla apla))(* pl2 pl2))
a2(* (* 2 pl1) apla)
aa(/ a1 a2)
ang2(atan (/ (sqrt (- 1 (* aa aa))) aa)))
(if (> (cadr pt2)(cadr pt1))
(setq ang(- ang1 ang2))
(setq ang(+ ang1 ang2))
)
(setq dfjd(polar pt2 ang pl1))
)
; 端缝线交点（前肋骨端点 肋骨与十字线交点 端缝实长 肋骨实长）
(defun dfjd1(pt2 pt1 pl1 pl2 / dfjd)
(setq apla(distance pt2 pt1)
ang1(angle pt2 pt1)
)
(setq a1(- (+ (* pl1 pl1)(* apla apla))(* pl2 pl2))
a2(* (* 2 pl1) apla)
aa(/ a1 a2)
ang2(atan (/ (sqrt (- 1 (* aa aa))) aa)))
(if (< (cadr pt2)(cadr pt1))
(setq ang(- ang1 ang2))
(setq ang(+ ang1 ang2))
)
(setq dfjd(polar pt2 ang pl1))
)
;qxqd(已知曲线 已知曲线上的点 已知曲线上的原点 待求点的曲线 待求点的曲线上的新点 原点
(defun qxqd(cur pt2 pt1 cur1 pt3 pt4 / ajl ajl1 p4a p4b aa)
(setq ajl(abs (- (vlax-curve-getDistAtPoint cur pt2)
(vlax-curve-getDistAtPoint cur pt1)))
);求出曲线上两点距离
(setq aj11 (vlax-curve-getDistAtPoint cur1 pt3));求出另一曲线开始点到指定点的距离
(Setq p4a(vlax-curve-getPointAtDist cur1 (+ aj11 ajl))
p4b(vlax-curve-getPointAtDist cur1 (- aj11 ajl))
);根据后曲线所得弧线长求出前反向弧长的坐标点（即该曲线的测地点）
(setq ajl(abs (- aj11 (vlax-curve-getDistAtPoint cur1 pt4)))
ajl1(abs (- (vlax-curve-getDistAtPoint cur1 pt4)
(vlax-curve-getDistAtPoint cur1 p4a)))
);求出曲线上两点距离
(if (>= ajl ajl1)
(setq aa p4a)
(setq aa p4b)
);求出该曲线的测地点
)
(defun C:wbzk()
(VL-LOAD-COM)
(setq osm (getvar"osmode"))
(prompt"第一步：按从冲势方向顺序依次选择首端缝前肋骨线、肋骨线、、未端缝后肋骨线")
(setq lgx(ssget));肋骨对象集
(setq lgs(atof (itoa(sslength lgx)));计算肋骨对象集中对象的数量
zjlg(FIX(/ lgs 2)));计算中间肋骨位置
(prompt"第二步：依次选择上端缝线、下端缝线")
(setq sdf(entsel"\n选择上端缝线：");上端线
xdf(entsel"\n选择下端缝线："));下端线
(setq splist nil
xplist nil
n -1
)
(setvar "osmode" 0)
(repeat (fix lgs)
(setq as(ssname lgx (setq n (1+ n)))
pt1(car(test (car sdf) as))
pt2(car (test (car xdf) as))
splist (append splist (list pt1));求出上端缝交点集
xplist (append xplist (list pt2));求出下端缝交点集
)
)
(setq pt1(list (/ (+ (car (nth 0 splist)) (car (nth 0 xplist))) 2)
(/ (+ (cadr (nth 0 splist)) (cadr (nth 0 xplist))) 2))
pt2(list (/ (+ (car (nth (- (fix lgs)1) splist)) (car (nth (- (fix lgs)1) xplist))) 2)
(/ (+ (cadr (nth (- (fix lgs)1) splist)) (cadr (nth (- (fix lgs)1) xplist))) 2))
);求出前端缝、未端缝弦线的中点
(setq PL1(ssname lgx 0)
PL2(ssname lgx (- (fix lgs) 1))
)
(setq cc1(vlax-curve-getClosestPointTo (vlax-ename->vla-object PL1) pt1)
cc2(vlax-curve-getClosestPointTo (vlax-ename->vla-object PL2) pt2)
)
(setq aaa(angle CC1 CC2)
CCA(polar CC1 (- aaa pi) 200)
CCb(polar CC2 aaa 200)
)
(command "line" cca ccb "");绘出前端缝、未端缝线垂线的连线
(setq PL1(entlast)
cdplists nil
n (+ 2 zjlg)
a n
)
(repeat a
(setq pl(ssname lgx (setq n(1- n))))
(if (/= pl nil)
(progn
(setq aa(car(test PL1 PL))
cdplists (append cdplists (list aa)))
)
)
);求出向首测地点点集
(setq cdplistw nil
n (- zjlg 1)
a (+ 1 zjlg)
)
(repeat a
(setq pl(ssname lgx (setq n(1+ n))))
(if (/= pl nil)
(progn
(setq aa(car(test PL1 PL))
cdplistw (append cdplistw (list aa)))
)
)
);求出向尾测地点点集
(entdel PL1)
(setq n (+ 1 zjlg)
scddj nil)
(setq m 0)
(repeat zjlg
(setq Pt1(nth (setq n(1- n)) splist)
Pt2(nth n xplist)
pt3(list (/ (+ (car pt1) (car pt2))2)
(/ (+ (cadr pt1) (cadr pt2))2)
)
)
(command "line" pt1 pt2 "")
(setq PL1(entlast))
(setq cc1(vlax-curve-getClosestPointTo (vlax-ename->vla-object PL1) (nth (setq m(1+ m)) cdplists)))
(entdel PL1)
(if (= (distance (nth m cdplists) cc1) 0.0)
(command "xline" (polar (nth m cdplists) pi 500) cc1 "")
(command "xline" (nth m cdplists) cc1 "")
)
(setq PL1(entlast)
PL2(ssname lgx (- N 1))
PL3(ssname lgx (+ 1 N))
)
(setq cc2(car (test PL1 PL3))
cc3(nth (1- m) cdplists)
cc4(nth (1+ m) cdplists)
cc5(car (test PL1 PL2))
)
(setq aa(qxqd PL3 cc2 cc3 PL2 cc5 cc4)
scddj (append scddj (list aa))
)
(entdel PL1)
);求出首测地点集
(setq n zjlg
wcddj nil)
(setq m 0)
(if (= (rem lgs 2 2) 0)
(setq a (- zjlg 2))
(setq a (- zjlg 1))
)
(repeat a
(setq Pt1(nth (setq n(1+ n)) splist)
Pt2(nth n xplist)
pt3(list (/ (+ (car pt1) (car pt2))2)
(/ (+ (cadr pt1) (cadr pt2))2)
)
)
(command "line" pt1 pt2 "")
(setq PL1(entlast))
(setq cc1(vlax-curve-getClosestPointTo (vlax-ename->vla-object PL1) (nth (setq m(1+ m)) cdplistw)))
(entdel PL1)
(if (= (distance (nth m cdplistw) cc1) 0.0)
(command "xline" (polar (nth m cdplistw) pi 500) cc1 "")
(command "xline" (nth m cdplistw) cc1 "")
)
(setq PL1(entlast)
PL2(ssname lgx (+ 1 N))
PL3(ssname lgx (- N 1))
)
(setq cc2(car (test PL1 PL3))
cc3(nth (1+ m) cdplistw)
cc4(nth (1- m) cdplistw)
cc5(car (test PL1 PL2))
)
(setq aa(qxqd PL3 cc2 cc4 PL2 cc5 cc3)
wcddj (append wcddj (list aa))
)
(entdel PL1)
);求出尾测地点集
;测地点排序
(setq n (length scddj)
cddj nil)
(repeat (length scddj)
(setq aa(nth (setq n(1- n)) scddj)
cddj (append cddj (list aa))
)
)
(setq n 2)
(repeat 2
(setq aa(nth (setq n(1- n)) cdplists)
cddj (append cddj (list aa))
)
)
(setq n -1)
(setq a(length wcddj))
(if (/= nil a)
(progn
(repeat a
(setq aa(nth (setq n(1+ n)) wcddj)
cddj (append cddj (list aa))
)
)
)
)
;接受输入肋骨间距
(prompt"第三步：按冲势方向依次输入肋距，如果肋距相同则只输入一个。输入格式a,b,c....")
(setq bs(strcase(GETstring "\n是变化肋距吗(y): ")))
(setq ljj nil)
(if (/= bs "Y")
(progn
(setq lj(atof (GETstring "\n输入肋距值: ")))
(repeat (fix (- lgs 1))
(setq ljj(append ljj (list lj)))
)
)
(progn
(setq ljj nil)
(setq lj(atof (GETstring "\请按从首向尾的顺序依次输入肋距值: ")))
(setq ljj(append ljj (list lj)))
(setq aa(length ljj))
(while (/= lj nil)
(setq lj(atof (GETstring "\下一个肋距值: ")))
(setq ljj(append ljj (list lj)));交点集
(setq aa(length ljj))
(if (= aa (- lgs 1))
(SETQ lj nil)
)
)
)
)
;计算上端肋骨实长
(setq aa(length splist)
n -1
sdgsc nil )
(repeat aa
(setq pts1(nth (setq n(1+ n)) splist)
pts2(nth n cddj)
lgll(ssname lgx n)
)
(setq lgs1(lgsc lgll pts1 pts2)
sdgsc(append sdgsc (list lgs1));交点集
)
)
;计算下端肋骨实长
(setq aa(length xplist)
n -1
xdgsc nil )
(repeat aa
(setq pts1(nth (setq n(1+ n)) xplist)
pts2(nth n cddj)
lgll(ssname lgx n)
)
(setq lgs1(lgsc lgll pts1 pts2)
xdgsc(append xdgsc (list lgs1));交点集
)
)
;计算上端肋距实长
(setq aa(length ljj)
n -1
sdjsc nil )
(repeat aa
(setq pts1(nth (setq n(1+ n)) splist)
pts2(nth (+ n 1) splist)
ljj1(nth n ljj)
)
(setq ljc(ljsc ljj1 pts1 pts2)
sdjsc(append sdjsc (list ljc));交点集
)
)
;计算中端肋距实长
(setq aa(length ljj)
n -1
zdjsc nil )
(repeat aa
(setq pts1(nth (setq n(1+ n)) cddj)
pts2(nth (+ n 1) cddj)
ljj1(nth n ljj)
)
(setq ljc(ljsc ljj1 pts1 pts2)
zdjsc(append zdjsc (list ljc));交点集
)
)
;计算下端肋距实长
(setq aa(length ljj)
n -1
xdjsc nil )
(repeat aa
(setq pts1(nth (setq n(1+ n)) xplist)
pts2(nth (+ n 1) xplist)
ljj1(nth n ljj)
)
(setq ljc(ljsc ljj1 pts1 pts2)
xdjsc(append xdjsc (list ljc));交点集
)
)
;计算肋骨冲势、旋转角
(setq pt11(nth zjlg splist)
pt12(nth zjlg xplist)
pt13(nth zjlg cddj)
pt14(nth (- zjlg 1) cddj)
pt15(nth (+ zjlg 1) cddj)
)
(command "line" pt11 pt12 "" )
(setq pl11(entlast))
(SETQ N 0)
(COMMAND "PLINE" (CAR cddj))
(REPEAT (LENGTH cddj)
(COMMAND (NTH (SETQ N (1+ N)) cddj))
)
(COMMAND "")
(COMMAND "pedit" (entlast) "f" f "")
(setq pl12(entlast))
(setq pt16(car (test pl11 pl12)))
(entdel pl12)
(if (> (abs (- (angle pt13 pt16) (angle pt13 pt14))) 0.8)
(progn
(setq pl13(ssname lgx (+ zjlg 1)))
(setq lj1(nth zjlg ljj))
(setq pt14a pt15)
)
(progn
(setq pl13(ssname lgx (- zjlg 1)))
(setq lj1(nth (- zjlg 1) ljj))
(setq pt14a pt14)
)
)
(setq cc1(vlax-curve-getClosestPointTo (vlax-ename->vla-object pl11) pt13))
(if (= (distance pt13 cc1) 0.0)
(command "xline" (polar pt13 pi 500) cc1 "")
(command "xline" pt13 cc1 "")
)
(setq pl14(entlast))
(setq pt17(car (test pl13 pl14)))
(setq as1(lgsc pl13 pt14a pt17))
(setq ss1(ljsc lj1 pt13 pt17))
(setq ss2(ljsc lj1 pt13 pt14a))
(setq pas(/ (- (+ (* ss1 ss1) (* ss2 ss2)) (* as1 as1)) (* (* 2 ss1) ss2)))
(setq pad(sqrt(- 1 (* pas pas))))
(setq ang (atan (/ pad pas)));求出的旋转角
(entdel pl11)
(entdel pl14)
(setq ccs(/ (* (distance pt13 cc1) (distance pt13 pt17)) ss1));求出的肋骨冲势
(setq accs ccs)
(setq ptt(getpoint "\n请指定插入展开图形的位置："))
(setq n -1
ll 0)
(REPEAT zjlg
(setq ll(+ ll (nth (setq n(1+ n)) zdjsc))
)
)
(setq n (- zjlg 1)
ll1 0)
(REPEAT (- (- (fix lgs) zjlg) 1)
(setq ll1(+ ll1 (nth (setq n(1+ n)) zdjsc))
)
)
(setq ptt1(list (- (car ptt) (+ ll ccs)) (cadr ptt))
ptt2(list (+ (car ptt) (- ll1 ccs)) (cadr ptt))
)
(command "line" ptt1 ptt2 "")
;求测地线坐标点集
(setq n -1
po nil)
(setq po(append po (list ptt1)))
(repeat (length zdjsc)
(setq pto(polar ptt1 0 (nth (setq n(1+ n)) zdjsc))
po(append po (list pto));交点集
)
(setq ptt1 pto)
)
;求中间肋骨上、下端点的坐标
(setq ang1(- (/ pi 2) ang)
ang2(+ pi ang1)
)
(setq pts(polar ptt ang1 (nth zjlg sdjsc))
ptx(polar ptt ang2 (nth zjlg sdjsc))
)
(command "xline" pts ptx "");绘制法线
(setq a1(entlast))
(command"circle" (nth zjlg po ) (nth zjlg sdgsc) )
(setq a2 (entlast))
(setq ptss(test a1 a2))
(setq ptss1(car ptss)
ptss2(cadr ptss)
)
(if(> (cadr ptss2) (cadr ptss1))
(setq pts ptss2)
(setq pts ptss1)
)
(entdel a2)
(command"circle" (nth zjlg po ) (nth zjlg xdgsc))
(setq a2 (entlast))
(setq ptss(test a1 a2))
(setq ptss1(car ptss)
ptss2(cadr ptss)
)
(if(> (cadr ptss2) (cadr ptss1))
(setq ptx ptss1)
(setq ptx ptss2)
)
(entdel a2)
(entdel a1)
(command "line" pts ptx "")
(setq szj(/ (* (angle ptx pts) 180) pi))
;求中间肋骨前的上、下端缝点坐标
(setq pa1 nil
n zjlg)
(setq pt2 pts)
(setq pa1(append pa1 (list pts)))
(repeat zjlg
(setq pt1 (nth (setq n(1- n)) po)
pl1 (nth n sdjsc)
pl2(nth n sdgsc)
)
(setq pts1(dfjd pt2 pt1 pl1 pl2)
pa1(append pa1 (list pts1));上端缝坐标
pt2 pts1)
)
(setq pa2 nil
n zjlg)
(setq pt2 ptx)
(setq pa2(append pa2 (list ptx)))
(repeat zjlg
(setq pt1 (nth (setq n(1- n)) po)
pl1 (nth n xdjsc)
pl2 (nth n xdgsc)
)
(setq pts2(dfjd pt2 pt1 pl1 pl2)
pa2(append pa2 (list pts2));下端缝坐标
pt2 pts2)
)
;求中间肋骨后的上、下端缝点坐标
(setq pb1 nil
n zjlg)
(setq pt2 pts)
(repeat (-(- (fix lgs) zjlg) 1)
(setq pt1 (nth (setq n(1+ n)) po)
pl1 (nth (- n 1) sdjsc)
pl2(nth n sdgsc)
)
(setq ptw1(dfjd1 pt2 pt1 pl1 pl2)
pb1(append pb1 (list ptw1));上端缝坐标
pt2 ptw1)
)
(setq pb2 nil
n zjlg)
(setq pt2 ptx)
(repeat (-(- (fix lgs) zjlg) 1)
(setq pt1 (nth (setq n(1+ n)) po)
pl1 (nth (- n 1) xdjsc)
pl2(nth n xdgsc)
)
(setq ptw1(dfjd1 pt2 pt1 pl1 pl2)
pb2(append pb2 (list ptw1));下端缝坐标
pt2 ptw1)
)
;求上端缝点坐标排序
(setq pa nil
n (length pa1)
)
(repeat (length pa1)
(setq pta(nth (setq n(1- n)) pa1)
pa(append pa (list pta))
)
)
(setq n -1)
(repeat (length pb1)
(setq pta(nth (setq n(1+ n)) pb1)
pa(append pa (list pta))
)
)
;求下端缝点坐标排序
(setq pb nil
n (length pa2)
)
(repeat (length pa2)
(setq ptb(nth (setq n(1- n)) pa2)
pb(append pb (list ptb))
)
)
(setq n -1)
(repeat (length pb2)
(setq ptb(nth (setq n(1+ n)) pb2)
pb(append pb (list ptb))
)
)
;绘制上端缝
(SETQ N 0)
(COMMAND "PLINE" (CAR pa))
(REPEAT (LENGTH pa)
(COMMAND (NTH (SETQ N (1+ N)) pa))
)
(COMMAND "")
(COMMAND "pedit" (entlast) "f" f "")
;绘制下端缝
(SETQ N 0)
(COMMAND "PLINE" (CAR pb))
(REPEAT (LENGTH pb)
(COMMAND (NTH (SETQ N (1+ N)) pb))
)
(COMMAND "")
(COMMAND "pedit" (entlast) "f" f "")
;绘制肋骨线
(SETQ N -1)
(REPEAT (LENGTH po)
(setq pt1(nth (setq n(1+ n)) pa)
pt2(nth n po)
pt3(nth n pb)
)
(command "pline" pt1 pt2 pt3 "")
(COMMAND "pedit" (entlast) "f" f "")
)
;打印型值
;旋转角
(setq xzj(strcat "旋转角度: "(rtos szj 2 1) "° " "中间肋骨编号：" (rtos zjlg)" ""中间肋骨冲势: " (rtos accs 2 1)))
(setq cd(- (length pa) 1))
(setq zfg(/ (distance (nth cd pa) (nth cd pb))(* 2 (length pa))))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) 200) 0))
(COMMAND "text" pt zfg 0 xzj)
;打印上端缝肋距
(SETQ N 0)
(setq zf1(strcat " " "0"", " (rtos(nth 0 sdjsc) 2 1)))
(REPEAT (- (LENGTH sdjsc) 1)
(setq xh(setq n(1+ n)))
(setq zf2(strcat zf1 " " (rtos xh)", " (rtos(nth n sdjsc) 2 1 )))
(setq zf1 zf2)
)
(setq zf11(strcat "上端缝肋距展开值： " zf1))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) (+ (* zfg 1.5) 200)) 0))
(COMMAND "text" pt zfg 0 zf11)
;打印地线肋距
(SETQ N 0)
(setq zf1(strcat " " "0"", " (rtos(nth 0 zdjsc) 2 1)))
(REPEAT (- (LENGTH zdjsc) 1)
(setq xh(setq n(1+ n)))
(setq zf2(strcat zf1 " " (rtos xh)", " (rtos(nth n zdjsc) 2 1 )))
(setq zf1 zf2)
)
(setq zf11(strcat "测地线肋距展开值： " zf1))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) (+ (* zfg 3) 200)) 0))
(COMMAND "text" pt zfg 0 zf11)
;打印下端缝肋距
(SETQ N 0)
(setq zf1(strcat " " "0"", " (rtos(nth 0 xdjsc) 2 1)))
(REPEAT (- (LENGTH xdjsc) 1)
(setq xh(setq n(1+ n)))
(setq zf2(strcat zf1 " " (rtos xh)", " (rtos(nth n xdjsc) 2 1 )))
(setq zf1 zf2)
)
(setq zf11(strcat "下端缝肋距展开值： " zf1))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) (+ (* zfg 4.5) 200)) 0))
(COMMAND "text" pt zfg 0 zf11)
;打印上端肋骨展开值
(SETQ N 0)
(setq zf1(strcat " " "0"", " (rtos(nth 0 sdgsc) 2 1)))
(REPEAT (- (LENGTH sdgsc) 1)
(setq xh(setq n(1+ n)))
(setq zf2(strcat zf1 " " (rtos xh)", " (rtos(nth n sdgsc) 2 1 )))
(setq zf1 zf2)
)
(setq zf11(strcat "上端肋骨展开值： " zf1))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) (+ (* zfg 6) 200)) 0))
(COMMAND "text" pt zfg 0 zf11)
(SETQ N 0)
(setq zf1(strcat " " "0"", " (rtos(nth 0 xdgsc) 2 1)))
(REPEAT (- (LENGTH xdgsc) 1)
(setq xh(setq n(1+ n)))
(setq zf2(strcat zf1 " " (rtos xh)", " (rtos(nth n xdgsc) 2 1 )))
(setq zf1 zf2)
)
(setq zf11(strcat "下端肋骨展开值： " zf1))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) (+ (* zfg 7.5) 200)) 0))
(COMMAND "text" pt zfg 0 zf11)
(setq zf11(strcat "程序操作者： " "白云"))
(setq pt(list (car (nth 0 pb)) (- (cadr (nth 0 pb)) (+ (* zfg 9) 200)) 0))
(COMMAND "text" pt zfg 0 zf11)
(setvar "osmode" osm)
) |
|
[复制链接]
提升卡
变色卡
楼主
