ac_lxy.lsp

plc设计编程软件

;****************************************;
;* This is "ac_lxy.lsp" program		*;		
;* It include some share functions	*;
;* Completely complied at 02/01/99	*;
;* Last changed  at 02/01/99		*;
;* ZX Mold Ltd  XY.Liao			*;
;****************************************;
;*************************** err handle function ****************************;
;;LCA - COMMENT: *error* defun no longer evaluates as a list.
;;LCA - COMMENT: *error* defun no longer evaluates as a list.
(defun-q *error*(msg)
  (if (= "quit / exit abort" msg)
    (setq msg nil)
  )
  (if (= "Function cancelled" msg)
    (setq msg nil)
  )
  (if msg
    (alert (strcat "错误:" msg))
  )
  (ac_lxy_set)
  (exit)
)
;****************************End of function********************************; 

;************************ system var reset function ************************;
(defun ac_lxy_set()
  (if la_old
    (setvar "clayer" la_old)
  )
  (if lt_old
    (setvar "celtype" lt_old)
  )
  (if co_old
    (setvar "cecolor" co_old)
  )
  (if pw_old
    (setvar "plinewid" pw_old)
  )
  (if os_old
    (setvar "osmode" os_old)
  )
  (if dim_old
    (command "dimstyle" "" dim_old)
  )
  (if st_old
    (setvar "textstyle" st_old)
  )
  (if or_old
    (setvar "orthomode" or_old)
  )
  (if bp_old
    (setvar "orthomode" bp_old)
  )
)
;****************************End of function********************************; 

;*********************** create wipeout box function ***********************;
(defun wipebox(lxy_ptlist)
  (command "_.pline")
  (foreach lxy_pt lxy_ptlist (command lxy_pt))
  (command "_c")
  (command "_.wipeout" "_frame" "_off")
  (command "_.wipeout" "_new" (entlast) "_yes")
  (entlast)
)
;****************************End of function********************************; 

;******************** init list box in dialog function *********************;
(defun ini_list(list_name table_name)
  (start_list list_name)
  (mapcar 'add_list table_name)
  (end_list)
)
;****************************End of function********************************; 

;******************* get item sequence in a list function ******************;
(defun xh_get(item list / n)
  (setq counti nil)
  (setq n 0)
  (while (< n (length list))
	(if (= item (nth n list))
	  (setq counti n)
	)
	(setq n (+ n 1))
  )
  (setq counti counti)
)
;********************************* End of function *********************************;

;************************** Change string to list function *************************;
(defun strtolst(string / i j ret_list)
  (setq i 2)
  (setq j 1)
  (while (<= i (strlen string))
    (if (= " " (substr string i 1))
      (progn
	(if ret_list
	  (setq ret_list (append ret_list (list (substr string j (- i j)))))
	  (setq ret_list (list (substr string j (- i j))))
	)
	(setq j (+ i 1))
      )
    )
    (if (and (<= j i) (= i (strlen string)))
      (setq ret_list (append ret_list (list (substr string j (+ (- i j) 1)))))
    )
    (setq i (+ i 1))
  )
  ret_list
)
;********************************* End of function *********************************;

;**************************** Get entities point function **************************;
;Return entities point list
;Lwpolyline---vertexes list
;Line---------start point and end point list
;Arc----------center point, start point and end point list
;circle-------center point and radius list
;Symtax: (ep_list entity_data)
;***********************************************************************************;
(defun ep_list(ent / en lst lst1 ptt1 ptt2 pt_1 pt_2 nt_l nt_h nt_r ent_n)

  (defun dxf(n e) (cdr (assoc n e)));defun local function

  (if (or (not ent) (not (listp ent)))
    (exit)
  )
  (if (setq en (dxf 0 ent))
    (cond
      ((= "LWPOLYLINE" en)
        (setq ptt1   (dxf 10 ent))
        (setq ent_n (dxf 90 ent))
        (setq ent   (member (assoc 10 ent) ent))
        (while (> ent_n 1)
          (setq bugl (dxf 42 ent))
          (setq ent (cdr ent))
          (if (= 0 bugl)
            (progn
              (setq ptt2  (dxf 10 ent))
              (setq lst1 (list "L" ptt1 ptt2))
            )
            (progn
              (setq ptt2 (dxf 10 ent))
	      (setq nt_l   (distance ptt1 ptt2)
		    nt_h   (abs (/ (* bugl nt_l) 2))
		    nt_r	(/ (* (+ (* bugl bugl) 1) nt_l) (* 4 (abs bugl)))
	      )
	      (cond
	        ((< bugl -1)
	          (setq pt_1     ptt2
			pt_2     ptt1
                  )
	 	  (setq ang1 (angle pt_1 pt_2)
			ang2 (- ang1 (/ pi 2))
		  )
		)
		((and (< bugl 0) (>= bugl -1))
	          (setq pt_1     ptt2
			pt_2     ptt1
                  )
	 	  (setq ang1 (angle pt_1 pt_2)
			ang2 (+ ang1 (/ pi 2))
		  )
		)
		((and (<= bugl 1) (> bugl 0))
	          (setq pt_1     ptt1
			pt_2     ptt2
                  )
	 	  (setq ang1 (angle pt_1 pt_2)
			ang2 (+ ang1 (/ pi 2))
		  )
		)
		((> bugl 1)
	          (setq pt_1     ptt1
			pt_2     ptt2
                  )
	 	  (setq ang1 (angle pt_1 pt_2)
			ang2 (- ang1 (/ pi 2))
		  )
		)
	      )
	      (setq mid_pt (polar pt_1 ang1 (/ nt_l 2))
		    cen_pt (polar mid_pt ang2 (abs (- nt_r nt_h)))
              )
	      (setq lst1 (list "A" cen_pt pt_1 pt_2))
            )
          )
	  (setq ptt1   (dxf 10 ent))
          (setq ent   (member (assoc 10 ent) ent))
	  (setq ent_n (- ent_n 1))
          (if lst
            (setq lst (append lst (list lst1)))
            (setq lst (list "PL" lst1))
          )
        )
      )
      ((= "LINE" en)
        (setq lst (list "L" (dxf 10 ent) (dxf 11 ent)))
      )
      ((= "CIRCLE" en)
        (setq lst (list "C" (dxf 10 ent) (dxf 40 ent)))
      )
      ((= "ARC" en)
        (setq arc_bpt (dxf 10 ent))
	(setq arc_r (dxf 40 ent))
        (setq arc_ang1 (dxf 50 ent))
        (setq arc_ang2 (dxf 51 ent))
        (setq arc_spt1 (polar arc_bpt arc_ang1 arc_r)
	      arc_spt2 (polar arc_bpt arc_ang2 arc_r)
        )
        (setq lst (list "A" arc_bpt arc_spt1 arc_spt2))
      )
    )
  )
  lst
)
;********************************* End of function *********************************;


;************************* Get intersection point function1 ************************;
;;===Return two line intersection point
;;===if    having int point and the point is on the side of end point2 
;;===then  return the point's ordinate
;;===else  return nil
;;===Sytex: (line_int <start_point1> <end_point1> <start_point2> <end_point2>)
;***********************************************************************************;
(defun line_int(point1 point2 point3 point4 / ret_flag1		ret_flag2)
  (setq line_inspt nil)
  (if (setq line_inspt (inters point1 point2 point3 point4 nil))
    (progn
      (setq angle1 (angle point3 point4))
      (setq angle2 (angle point3 line_inspt))
      (if (> 0.0001 (abs (- angle1 angle2)))
        (setq ret_flag1 T)
        (setq ret_flag1 nil)
      )
      (if (or (and (>= (car line_inspt) (car point1)) (<= (car line_inspt) (car point2)))
	      (and (<= (car line_inspt) (car point1)) (>= (car line_inspt) (car point2)))
	      (and (>= (cadr line_inspt) (cadr point1)) (<= (cadr line_inspt) (cadr point2)))
	      (and (<= (cadr line_inspt) (cadr point1)) (>= (cadr line_inspt) (cadr point2)))
          )
        (setq ret_flag2 t)
        (setq ret_flag2 nil)
      )
    )
  )
  (if (and line_inspt ret_flag1 ret_flag2)
    line_inspt
    nil
  )
)
;********************************* End of function *********************************;


;************************* Get intersection point function2 ************************;
;;=Return the intersection point of a line and a arc
;;=if    having int point and the point is on the side of end_pt_line 
;;=then  return the point's ordinate list
;;=else  return nil
;;=Sytex: (arc_int <cen_pt>  <start_pt_arc>  <end_pt_arc>  <start_pt_line>  <end_pt_line>)
;***********************************************************************************;
(defun arc_int(point0 point1 point2 point3 point4 
;/ ret_pt1 	ret_pt2 	pt_temp1 
;						    pt_temp2 	ang_temp1 	ang_temp2
;						    ang_temp3 	ang1 		ang2 
;						    ang3
)
(princ "arc_int\n")
  (setq cir (distance point0 point1))
  (setq ang1 (angle point0 point1)
	ang2 (angle point0 point2)
	ang3 (angle point3 point4)
  )
  (if (> ang1 ang2)
    (setq ang1 (- ang1 (* pi 2)))
  )
  (if (setq intpt_sel (circ_int point3 point4 point0 cir))
    (if (= 1 (length intpt_sel))
      (progn
	(setq pt_temp1 (car intpt_sel))
        (setq ang_temp1 (angle point0 pt_temp1))
	(setq ang_temp3 (angle point3 pt_temp1))
	(if (and (> 0.0001 (abs (- ang3 ang_temp3)))
		 (and (>= ang_temp1 ang1) (<= ang_temp1 ang2))
            )
          (setq ret_pt1 pt_temp1)
        )
      )
      (progn
	(setq pt_temp1 (car intpt_sel))
	(setq pt_temp2 (cadr intpt_sel))
	(setq ang_temp1 (angle point0 pt_temp1))
	(setq ang_temp2 (angle point0 pt_temp2))
	(setq ang_temp3 (angle point3 pt_temp1))
	(setq ang_temp4 (angle point3 pt_temp2))
	(if (and (> 0.0001 (abs (- ang3 ang_temp3)))
		 (or (and (>= ang_temp1 ang1) (<= ang_temp1 ang2))
		     (and (>= (- ang_temp1 (* pi 2)) ang1) (<= (- ang_temp1 (* pi 2)) ang2))
                 )
            )
          (setq ret_pt1 pt_temp1)
          (setq ret_pt1 nil)
        )
	(if (and (> 0.0001 (abs (- ang3 ang_temp4)))
		 (and (>= ang_temp2 ang1) (<= ang_temp2 ang2))
            )
          (setq ret_pt2 pt_temp2)
          (setq ret_pt2 nil)
        )
      )
    )
  )
  (if (not ret_pt2)
    (if (not ret_pt1)
      nil
      ret_pt1
    )
    (if (not ret_pt1)
      ret_pt2
      (if (> (distance point3 ret_pt1) (distance point3 ret_pt2))
        (list ret_pt2 ret_pt1)
        (list ret_pt1 ret_pt2)
      )
    )
  )
)
;********************************* End of function *********************************;


;************************* Get intersection point function3 ************************;
;* Return the intersection point of a line and a circle
;* if having int point, the return value is the point's ordinate list
;* else the return value is nil
;* Sytex: (circ_int  start_pt_line  end_pt_line  center_pt_circle  radius_circle)
;***********************************************************************************;
(defun circ_int(point1 point2 pt_cen cir / ver_lb 	k 		b 		a0 
					   b0 		c0 		temp 		pt1_temp 
					   pt2_temp	x1 		x2 		y1 
					   y2)
  (if (< (abs (- 1.0 (/ (car point1) (car point2)))) 0.0001);if line is parallelism to y axis
    (setq ver_lb 1)					    ;then
    (setq ver_lb 0)					    ;else
  );if
  (cond 
    ((= 0 ver_lb)

  ;;;;k=(y2-y1)/(x2-x1);;;;
      (setq k (/ (- (cadr point2) (cadr point1)) 
 	         (- (car point2) (car point1)))) 

  ;;;b=(x2y1-x1y2)/(x2-x1);;;
      (setq b (/ (- (* (car point2) (cadr point1)) 
		    (* (car point1) (cadr point2))
		 ) 
		 (- (car point2) (car point1)))) 

  ;;;;a0=k^2+1;;;;
      (setq a0 (+ 1 (* k k))) 

  ;;;;b0=2kb-(2x0+2ky0);;;;
      (setq b0 (- (* 2 k b) 
                  (+ (* 2 (car pt_cen)) 
		     (* 2 k (cadr pt_cen))
		  )
	       )) 

  ;;;;c0=x0^2+(b-y0)^2+r^2;;;;
      (setq c0 (- (+ (* (car pt_cen) (car pt_cen)) 
		     (* (- b (cadr pt_cen)) (- b (cadr pt_cen)))
		  ) 
                  (* cir cir))) 

  ;;;;temp=b^2-4a0c0;;;;
      (setq temp (- (* b0 b0) (* 4 a0 c0))) 

      (if (>= temp 0) ;if temp>=0
        (progn
 	  (setq x1 (/ (+ (- 0 b0) (sqrt temp)) (* 2 a0)))
 	  (setq y1 (+ (* k x1) b))
 	  (setq x2 (/ (- (- 0 b0) (sqrt temp)) (* 2 a0)))
 	  (setq y2 (+ (* k x2) b))
 	  (setq pt1_temp (list x1 y1))
 	  (setq pt2_temp (list x2 y2))
 	  (if (= 0 temp)
	    (setq pt2_temp nil)
	  )
        )
        (setq pt1_temp nil