(vl-load-com)
(prompt "命令是YG")
;;;画衣柜的LISP程序-----------------------------------------------------
;;;Copyright Highflybird------------------------------------------------
;;;2011.04.30 ----------------------------------------------------------
(defun c:YG(/ lst doc size pIn str pnt pts scr dlt dist1 dist2 Vec dist
lst1 lst2 lst3 cur1 cur2 Cur3 obj1 obj2 Obj3 Objs sLen ang1 ang2 ang par
)
(if (< (setq size (getvar "USERR5")) 100.) ;初始化衣柜深
(progn
(setvar "USERR5" 600.)
(setq size 600.)
)
)
;;获取布置一侧，或设置衣柜深
(setq str "\n点取布置的一侧[设置(Set)] <走向右侧>:") ;获取布置方向
(initget 8 "Set")
(setq pIn (getpoint str))
(while (= pIn "Set")
(setq size (getvar "USERR5"))
(initget 14)
(setq size (getdist (strcat "\n输入衣柜深<" (rtos size) ">:"))) ;如果需要设置衣柜深
(if (>= size 100)
(setvar "USERR5" size)
(setq size (getvar "USERR5"))
)
(initget 8 "Set")
(setq pIn (getpoint str))
)
;;获取靠墙边
(initget 9) ;防止空输入，点可在画面外
(setq pnt (getpoint "\n起点:"))
(setq pts (cons pnt nil))
(setq str "\n选取点<回车,空格或右键结束点取>:")
(while (setq pnt (getpoint (car pts) str)) ;通过点取方式获得靠墙边
(setq pnt (list (car pnt) (cadr pnt))) ;这步不可少，防止不在同个平面上
(grdraw pnt (car pts) 3 1) ;虚线显示布置靠墙边
(setq pts (cons pnt pts))
)
;;输入完成开始画图
(if (> (length pts) 1) ;至少要两点
(progn
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark doc) ;设置Undo起始点
(setq scr (GetRandFunction))
;;一些初始化工作--------------------------------------------------
(setq pts (reverse pts)) ;点集反转
(setq pts (mapcar (function (lambda (x) (trans x 1 0))) pts)) ;把点集转化到世界坐标系
(if pIn
(setq pIn (trans pIn 1 0)
dlt (det (car pts) (cadr pts) pIn) ;右手法则
)
)
(if (> dlt 0) ;通过右手法则判断偏移方向
(setq dist1 (* size 0.5)
dist2 size
)
(setq dist1 (* size -0.5)
dist2 (- size)
)
)
;;首先构建衣柜的外轮廓和中心线------------------------------------
(setq lst1 (OffsetPts pts dist1 nil)) ;衣柜的中心线点
(setq lst2 (OffsetPts pts dist2 nil))
(setq lst2 (append pts (reverse lst2))) ;衣柜的外轮廓点
(setq Cur1 (make-Poly lst1 nil)) ;画衣柜的中心线
(setq Cur2 (make-Poly lst2 T)) ;画衣柜的中心线
(setq Obj1 (vlax-ename->vla-object Cur1))
(setq Obj2 (vlax-ename->vla-object Cur2))
(setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
(setq Cur3 (make-Poly lst3 T))
(setq obj3 (vlax-ename->vla-object Cur3))
(setq lst (list obj1 obj2 obj3))
(setq Objs (Make-clothes-hanger)) ;画衣架
(setq dist 0.0)
(setq sLen (vla-get-length Obj1)) ;中心线长度
(setq ang1 (/ pi 0.1 180)) ;摆动幅度在10度左右
(setq ang2 (- ang1))
(while (< dist sLen)
(setq pnt (vlax-curve-getPointAtDist Obj1 dist)) ;衣架的定位点
(setq par (vlax-curve-getParamAtDist Obj1 dist))
(setq Vec (vlax-curve-getFirstDeriv Obj1 par)) ;衣架的水平方向
(setq ang (angle '(0 0 0) Vec))
(setq ang (+ ang (Rand scr ang1 ang2))) ;衣架的旋转角度
(setq pIn (vlax-curve-getPointAtParam obj1 (fix (+ 0.5 par)))) ;转点
(if (>= (distance pnt pIn) 300) ;如果与转点距离大于300
(Copy-and-tranformby Objs pnt ang) ;拷贝原点处衣架并变换
)
(setq dist (+ dist (Rand scr 80 300))) ;步进到下一点(100,300)这两个数值可自调
)
(mapcar 'vla-erase Objs) ;把原点处衣架删除
(makeGroup Doc Lst)
(vlax-release-object scr) ;释放脚本实例
(vla-EndUndoMark doc) ;设置Undo终止点
(vlax-release-object doc)
)
)
(redraw) ;重画一下，消除Grdraw的痕迹
(princ) ;静默退出
)|;
(defun sign (x)
(if (< x 0) -1 1)
)
;;;出错处理
(defun *error_msg* (msg)
(redraw)
(princ msg)
)
;;;画线段
(defun Make-Line (p q)
(entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
)
;;;绘制多段线
(defun Make-Poly (pp isClosed / C)
(if isClosed
(setq C 1)
(setq C 0)
)
(entmakeX ;画凸包
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length pp)) ;顶点个数
(cons 70 C) ;闭合的
)
(mapcar (function (lambda (x) (cons 10 x))) pp) ;多段线顶点
)
)
)
;;;画衣架
(defun Make-clothes-hanger (/)
(mapcar
(function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
'((-17.5 -225.) (+17.5 -225.) (-35.0 -210.) (-35.0 +210.))
'((-17.5 +225.) (+17.5 +225.) (+35.0 -210.) (+35.0 +210.))
)
)
;;;拷贝原点处的物体并变换
(defun Copy-and-tranformby (Objs pnt Ang / newObj)
(foreach obj Objs
(setq NewObj (vla-copy obj))
(vla-move NewObj (vlax-3d-point '(0 0 0)) (vlax-3d-point pnt))
(vla-rotate NewObj (vlax-3d-point pnt) Ang)
(setq lst (cons NewObj lst))
)
)
;;;最后做成组
(defun MakeGroup (Doc objLst / Groups sGroup oGroup aBound eArray)
(setq Groups (vla-get-groups doc))
(setq sGroup (getvar "cdate"))
(setq sGroup (rtos (* 1e9 (- sGroup (fix sGroup))) 2 0))
(setq oGroup (vla-add Groups (strcat "YG" sGroup)))
(setq aBound (cons 0 (1- (length objLst))))
(setq eArray (vlax-make-safearray vlax-vbObject aBound))
(vlax-safearray-fill eArray objLst)
(vla-AppendItems oGroup eArray)
)
;;;偏移点集(没用vla-offset)
;;;此函数可以扩展，为以后的编程准备
(defun OffsetPts (pts d isClosed / AN1 AN2 CNT HPI LST PN1 PN2 PN3 PN4 PNT PPP PT1 PT2 PT3 P12)
(setq ppp pts)
(setq cnt (length ppp))
(cond
( (>= cnt 2)
(setq hPi (/ Pi 2))
(setq pt1 (car ppp))
(setq pt2 (cadr ppp))
(setq an1 (angle pt1 pt2))
(setq pn1 (polar pt1 (+ an1 hPi) d))
(setq pn2 (polar pt2 (+ an1 hPi) d))
(setq pn4 pn2)
(setq lst (list pn1))
(if isClosed
(setq ppp (append pts (list (car pts)))
p12 (list pn1 pn2)
)
)
(while (caddr ppp)
(setq pt1 (car ppp))
(setq pt2 (cadr ppp))
(setq pt3 (caddr ppp))
(setq an1 (angle pt1 pt2))
(setq pn1 (polar pt1 (+ an1 hPi) d))
(setq pn2 (polar pt2 (+ an1 hPi) d))
(setq an2 (angle pt2 pt3))
(setq pn3 (polar pt2 (+ an2 hPi) d))
(setq pn4 (polar pt3 (+ an2 hPi) d))
(setq pnt (inters pn1 pn2 pn3 pn4 nil))
(and pnt (setq lst (cons pnt lst)))
(setq ppp (cdr ppp))
)
(if isClosed
(setq lst (cdr (reverse lst))
pnt (inters pn3 pn4 (car p12) (cadr p12) nil)
lst (cons pnt lst)
)
(setq lst (cons pn4 lst)
lst (reverse lst)
)
)
(vl-remove nil lst)
)
)
)
;;;===============
;;;行列式,判别法则
;;;===============
(defun det (p1 p2 p3 / x1 y1)
(setq x1 (car p1)
y1 (cadr p1)
)
(- (* (- (car p2) x1) (- (cadr p3) y1))
(* (- (car p3) x1) (- (cadr p2) y1))
)
)
;;;---------------------------------------------------------------------
;;;Definine Rand() --which one is better? I don't know.
;;;---------------------------------------------------------------------
(defun GetRandFunction(/ scr str)
(setq scr (vlax-create-object "ScriptControl")) ;Create a script
(if scr
(progn
(vlax-put scr 'Language "VBS")
(setq str "Randomize\n
Function Rand(x,y)\n
Rand=x+Rnd*(y-x)\n
End Function"
) ;for randomize some features
(vlax-invoke Scr 'ExecuteStatement str) ;Execute script
(defun Rand (scr nMin nMax) ;Rand function
(vlax-invoke scr 'run "Rand" nMin nMax)
)
)
;;;rand function-some code from Le,--thanks.
(defun Rand (Option nMin nMax / seed)
(setq seed (getvar "USERR4"))
(if (= seed 0.)
(setq seed (getvar "TDUSRTIMER")
seed (- seed (fix seed))
seed (rem (* seed 86400) 1)
)
)
(setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
(setvar "USERR4" seed)
(+ nMin (* seed (- nMax nMin)))
)
)
scr
)
Sunday, January 20, 2013
画衣柜的程序
Subscribe to:
Post Comments (Atom)
No comments:
Post a Comment