[编程交流] 绘制相交线

;hanhphuc @cadtutor 15/07/14
;Draw interfingering?
;http://www.cadtutor.net/forum/showthread.php?87594-Draw-Interfingering-lines
;Revision: 1.0        22/07/2014
;flatshot idea suggested by Marko Ribar         
;debugging....
(defun C:TEST (/ *error*  oldecho p l d e ab solid ro 2D)
 (defun *error* (msg)
   (if        (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*"))
     (princ (strcat "\nError: " msg))
     ) ;_ end of if
   (princ)
   ) ;_ end of defun
 (terpri)
 (setq oldecho (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (setq        *user* (hp# 'getdist
            '(6 6 )
            '("\nDiameter of horizontal cylinder "
              "\nDiameter of branch cylinder "
                     )
            *user*
            ) ;_ end of hp#
d (* (car *user*) 2.)
ro (getorient "\nBranch angle in degrees : ")
p '(0. 0. 0.)
   
solid
(mapcar        '(lambda (r a b c / ab)
   (apply 'vla-Rotate3D
          (append (cons        (setq ab (vla-AddCylinder *mspace* (vlax-3d-point a) (/ r 2.) b))
                        (mapcar        '(lambda (x) (vlax-3d-point x))
                                '((0. 0. 0.) (0. 1. 0.)) ;(car (split *user* 2 t))
                                ) ;_ end of mapcar
                        ) ;_ end of cons
                  (list c)
                  ) ;_ end of append
          ) ;_ end of apply
   ab
   ) ; lambda
*user* ;diameter
(list '(0. 0. 0.) (list (car p) (cadr p) (+ (caddr p) (car *user*))))
(list (* d 2) d)
(list (/ pi 2.)
      (if ro
        (- (* 2.5 pi) ro)
        0.0
        ) ;_ end of if
      )
) ; mapcar
   ); setq
(initget "Yes No y n")
(setq 2D (getkword "\nMake solid 3D [Yes/No]? <No> : "))
(if (or(= 2D "No")(not 2D ))
(progn
(command "_vpoint" "0,-1,0");
(vl-cmdf "flatshot" "" (getvar "viewctr") 1 1 0 )
(if solid 
('((x) (vla-boolean (cadr x) 2 (car x)));acSubtraction
solid))
(vl-cmdf "flatshot" "" (getvar "viewctr") 1 1 0 )
(entdel (vlax-vla-object->ename (cadr solid )))
(command "_vpoint" "0,0,0");
)
(progn
('((x) (vla-boolean (car x) 2 (cadr x)))
solid)
(command "vpoint" "1,-1,1")
(command "_VSCURRENT" "Conceptual")
   )
 );if
 
(setvar "cmdecho" oldecho)
 (princ "\nDone..")
 (princ)
) ;_ end of defun
(if (null *user*)
 (setq *user* '(10. 9.0 ) )
 ) ; variable global
(princ "\nhanphuc@cadtutor 2014. Command: TEST")
(princ)
(vl-load-com)
(setq *mspace* (vla-get-modelspace (vla-get-ActiveDocument(vlax-get-acad-object))))
;;;----------------------------------------------------                
;;;                                                                
;; courtesy of the author's of "Inside AutoLisp"                
;; for rel. 10 published by New Riders Publications                 
;; Referenced to the concept of UREAL UKWORD,                        
;; which inspired me make this utility #hp                        
;; also thanks to ymg the way of handling variable in list        
;;                                                                 
;HP# ; user prompt for numbers by hanhphuc 2014
 (defun hp# (_f _ini _msg _def  / usr l)
 (if (and
(member _f '(getreal getint getdist))
         (vl-every '(lambda (x) (= (type x) 'INT)) _ini )
  )
   (progn (setq usr (mapcar '(lambda ( i a b) (initget i)
                ((eval _f) (strcat a " < "(rtos b) " > : ")))
                     _ini
                     _msg
                     _def
                     ) ;_ end of mapcar
         ) ; setq
   (while usr
     (setq l (cons (if (null (car usr))
                        (car _def)
                        (car usr)
                        ) ;_ end of if
                      l
                      ) ;_ end of cons
           usr        (cdr usr)
           _def        (cdr _def)
           ) ;_ end of setq
     l
     ) ;_ end of while
   (reverse l)
   ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of defun
;sub function: split
;http://www.cadtutor.net/forum/showthread.php?87320-Break-a-list-in-two-sub-lists&highlight=Split+list
(defun split (lst len opt / ls l i) ; opt, T= by division or nil=by length
(setq i 1 l '() len (if opt (/ (length lst) len) len))
 (while lst
   (setq l (append  l (list(car lst))))
   (if
   (zerop (rem i len))
(setq ls (cons l ls) l nil)
   ) 
   (setq i (1+ i) lst (cdr lst))
 ) ;_ end of foreach
 (if l
   (append (reverse ls) (list  l))
   (reverse ls)
 ) ;_ end of if
) ;_ end of defun

(defun c:tj (/ d1 d2 ud2 uu1 apdeg apr ap r1 r2 a b c d e f e1 cp1)
 (command "_.undo" "_begin")
 (setq osn (getvar "osmode"))
 (setvar "cmdecho" 0)
 (setq oerr *error*)
 (defun *error* (msg)
   (setvar "osmode" osn)
   (princ "\n Function cancelled - Try again ")
   (setq *error* oerr)
   (command)
   (princ)
 )
 (princ "\n Straight pipe diameter < ")
 (if dd1
   (princ dd1)                                ; prints default value
 )
 (princ " > ?? :")
 (setq d1 (getdist))
 (if (= d1 nil)
   (setq d1 dd1)
 )
 (setq dd1 d1)
 (princ "\n Branch pipe diameter < ")
 (if dd2
   (princ dd2)
 )                                        ; prints default value
 (princ " > ?? :")
 (setq d2 (getdist))
 (if (= d2 nil)
   (setq d2 dd2)
 )
 (setq dd2 d2)
 (if (> d2 d1)
   (progn
     (alert
" Branch pipe diameter must be equal or smaller than straight pipe\nSTART OVER"
     )
     (^c^c)
   )
 )
 (if ud1
   (setq ud2 (* (/ ud1 pi) 180))
 )
 (princ "\n Branch pipe entry angle < ")
 (if ud1
   (princ ud2)                                ; prints default value
 )
 (princ " > ?? : ")
 (setq uu1 (getangle))
 (if (= uu1 nil)
   (setq uu1 ud1)
 )
 (if (>= uu1 pi)
   (progn
     (alert "Angle must be smaller than 180 deg\nStart over")
     (c^c^)
   )
 )
 (if (= uu1 0)
   (c^c^)
 )
 (setq ud1 uu1)
 (setq u1 (* (/ uu1 pi) 180))
 (setq apdeg 10.0)                        ;angle of precision
 (setq ap (/ (* apdeg pi) 180))
 (setq apr ap)
 (setq ip (getpoint "\n Curve insertion (left endpoint): "))
 (setq r1 (/ d1 2))
 (setq r2 (/ d2 2))
 (setvar "osmode" 0)
 (setq a (- r2 (* r2 (cos ap))))
 (setq b (/ a (sin uu1)))
 (setq c (* r2 (sin ap)))
 (setq d (- r1 (sqrt (- (expt r1 2) (expt c 2)))))
 (setq f (- b (/ d (tan uu1))))
 (setq cp1 (polar ip 0 f))
 (setq p1 (polar cp1 (* pi 1.5) d))
 (command "pline" ip "w" 0 0 p1 "")
 (setq e (entlast))
 (setq ap (+ ap apr))
 (while (< ap pi)
   (setq a (- r2 (* r2 (cos ap))))
   (setq b (/ a (sin uu1)))
   (setq c (* r2 (sin ap)))
   (setq d (- r1 (sqrt (- (expt r1 2) (expt c 2)))))
   (setq f (- b (/ d (tan uu1))))
   (setq cp1 (polar ip 0 f))
   (setq p1 (polar cp1 (* pi 1.5) d))
   (command "line" "" p1 "")
   (setq e1 (entlast))
   (command "pedit" e "j" e1 "" c^c^)
   (setq ap (+ ap apr))
 )
 (command "pedit" e "f" "" c^c^)
 (setvar "osmode" osn)
 (command "rotate" e "" ip pause)
 (command "_.undo" "_end")
 (princ "\n\n\n\n Straight pipe dia = ")
 (princ d1)
 (princ "\n Branch pipe dia   = ")
 (princ d2)
 (princ "\n Branch pipe angle = ")
 (princ u1)
 (princ)
)