画衣柜的LISP程序的画平面衣柜

admin1

[code](vl-load-com)
(prompt "命令是YG")
;;;画衣柜的LISP程序-----------------------------------------------------
;;;Copyright Highflybird------------------------------------------------
;;;2011.04.30 ----------------------------------------------------------
(defun c:xr_YG1(/ 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")) 200.)                            ;初始化衣柜深
    (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 200)
      (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) 18) 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 160))                                        ;摆动幅度在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 60 200)))                          ;步进到下一点(100,300)这两个数值可自调
      )
      (mapcar 'vla-erase Objs)                                          ;把原点处衣架删除
      (makeGroup Doc Lst)
      (and scr (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 (reverse (cdr (reverse (trans x 1 0)))))
          )
        )
        pp
      )                                                                   ;多段线顶点
    )
  )
)

;;;画衣架
(defun Make-clothes-hanger (/)
  (mapcar
    (function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
    '((-17.5 -225.) (+17.5 -225.) (-17.5 -225.) (-17.5 +225.))
    '((-17.5 +225.) (+17.5 +225.) (+17.5 -225.) (+17.5 +225.))
  )
)

;;;拷贝原点处的物体并变换
(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
)
[/code]