[编程交流] 用“或”填充一个区域

(defun c:snakefill-2curveboundaries (/ *adoc* odd even osm pea ch r lpl upl ip dir lplo uplo spc xl1 c1 xl2 c2 cl ss)
 (defun odd (lst)
   (if lst (cons (car lst) (odd (cddr lst))))
 )
 
 (defun even (lst)
   (if lst (cons (cadr lst) (even (cddr lst))))
 )
 (vl-load-com)
 (setq *adoc* (vla-get-activedocument (vlax-get-acad-object)))
 
 (setq osm (getvar 'osmode))
 (setq pea (getvar 'peditaccept))
 (setvar 'osmode 0)
 (command "_.ucs" "w")
 (initget 1 "Left-Right Up-Down")
 (setq ch (getkword "\nChoose option (Left-Right / Up-Down) curve boundaries: "))
 (initget 7)
 (setq r (getdist "\nSpecify radius of snake turn: "))
 (if (eq ch "Up-Down")
   (progn
     (setq lpl (car (entsel "\nPick lower curve boundary...")))
     (setq upl (car (entsel "\nPick upper curve boundary...")))
     (setq ip (getpoint "\nPick start point ("left" - Up-Down or "bottom" - Left-Right): "))
     (initget 1 "Up Down")
     (setq dir (getkword "\nChoose start direction (Up / Down): "))
     (if (eq dir "Up")
       (progn
         (command "_.offset" r lpl ip "")
         (setq lplo (entlast))
         (command "_.offset" r upl ip "")
         (setq uplo (entlast))
         (setq spc (vla-ObjectIdToObject *adoc* (vla-get-OwnerId (vlax-ename->vla-object lpl))))
         (setq c1 T c2 T k -3.0)
         (while (and c1 c2)
           (setq xl1 (vlax-invoke spc 'addxline (polar ip 0.0 (* r (setq k (+ k 4.0)))) (polar (polar ip 0.0 (* r k)) (* pi 0.5) 1.0)))
           (setq c1 (vlax-invoke xl1 'intersectwith (vlax-ename->vla-object uplo) acextendnone))
           (vla-delete xl1)
           (setq xl2 (vlax-invoke spc 'addxline (polar ip 0.0 (* r (+ k 2.0))) (polar (polar ip 0.0 (* r (+ k 2.0))) (* pi 0.5) 1.0)))
           (setq c2 (vlax-invoke xl2 'intersectwith (vlax-ename->vla-object lplo) acextendnone))
           (vla-delete xl2)
           (if c1 (setq cl (cons c1 cl)))
           (if (and c1 c2) (setq cl (cons c2 cl)))
         )
         (setq cl (reverse cl))
         (setq ss (ssadd))
         (foreach c (vl-remove nil (odd cl))
           (command "_.arc" (polar c pi r) (polar c (* pi 0.5) r) (polar c 0.0 r))
           (ssadd (entlast) ss)
         )
         (foreach c (vl-remove nil (even cl))
           (command "_.arc" (polar c pi r) (polar c (* pi -0.5) r) (polar c 0.0 r))
           (ssadd (entlast) ss)
         )
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p 0.0 r)) (vl-remove nil (odd cl))) (mapcar '(lambda (p) (polar p pi r)) (vl-remove nil (even cl))))
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p 0.0 r)) (vl-remove nil (even cl))) (mapcar '(lambda (p) (polar p pi r)) (vl-remove nil (cdr (odd cl)))))
         (command "_.line" ip (polar (car cl) pi r) "")
         (ssadd (entlast) ss)
       )
       (progn
         (command "_.offset" r lpl ip "")
         (setq lplo (entlast))
         (command "_.offset" r upl ip "")
         (setq uplo (entlast))
         (setq spc (vla-ObjectIdToObject *adoc* (vla-get-OwnerId (vlax-ename->vla-object lpl))))
         (setq c1 T c2 T k -3.0)
         (while (and c1 c2)
           (setq xl1 (vlax-invoke spc 'addxline (polar ip 0.0 (* r (setq k (+ k 4.0)))) (polar (polar ip 0.0 (* r k)) (* pi 0.5) 1.0)))
           (setq c1 (vlax-invoke xl1 'intersectwith (vlax-ename->vla-object lplo) acextendnone))
           (vla-delete xl1)
           (setq xl2 (vlax-invoke spc 'addxline (polar ip 0.0 (* r (+ k 2.0))) (polar (polar ip 0.0 (* r (+ k 2.0))) (* pi 0.5) 1.0)))
           (setq c2 (vlax-invoke xl2 'intersectwith (vlax-ename->vla-object uplo) acextendnone))
           (vla-delete xl2)
           (if c1 (setq cl (cons c1 cl)))
           (if (and c1 c2) (setq cl (cons c2 cl)))
         )
         (setq cl (reverse cl))
         (setq ss (ssadd))
         (foreach c (vl-remove nil (odd cl))
           (command "_.arc" (polar c pi r) (polar c (* pi -0.5) r) (polar c 0.0 r))
           (ssadd (entlast) ss)
         )
         (foreach c (vl-remove nil (even cl))
           (command "_.arc" (polar c pi r) (polar c (* pi 0.5) r) (polar c 0.0 r))
           (ssadd (entlast) ss)
         )
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p 0.0 r)) (vl-remove nil (odd cl))) (mapcar '(lambda (p) (polar p pi r)) (vl-remove nil (even cl))))
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p 0.0 r)) (vl-remove nil (even cl))) (mapcar '(lambda (p) (polar p pi r)) (vl-remove nil (cdr (odd cl)))))
         (command "_.line" ip (polar (car cl) pi r) "")
         (ssadd (entlast) ss)
       )
     )
   )
   (progn
     (setq lpl (car (entsel "\nPick right curve boundary...")))
     (setq upl (car (entsel "\nPick left curve boundary...")))
     (setq ip (getpoint "\nPick start point ("left" - Up-Down or "bottom" - Left-Right): "))
     (initget 1 "Left Right")
     (setq dir (getkword "\nChoose start direction (Left / Right): "))
     (if (eq dir "Left")
       (progn
         (command "_.offset" r lpl ip "")
         (setq lplo (entlast))
         (command "_.offset" r upl ip "")
         (setq uplo (entlast))
         (setq spc (vla-ObjectIdToObject *adoc* (vla-get-OwnerId (vlax-ename->vla-object lpl))))
         (setq c1 T c2 T k -3.0)
         (while (and c1 c2)
           (setq xl1 (vlax-invoke spc 'addxline (polar ip (* pi 0.5) (* r (setq k (+ k 4.0)))) (polar (polar ip (* pi 0.5) (* r k)) 0.0 1.0)))
           (setq c1 (vlax-invoke xl1 'intersectwith (vlax-ename->vla-object uplo) acextendnone))
           (vla-delete xl1)
           (setq xl2 (vlax-invoke spc 'addxline (polar ip (* pi 0.5) (* r (+ k 2.0))) (polar (polar ip (* pi 0.5) (* r (+ k 2.0))) 0.0 1.0)))
           (setq c2 (vlax-invoke xl2 'intersectwith (vlax-ename->vla-object lplo) acextendnone))
           (vla-delete xl2)
           (if c1 (setq cl (cons c1 cl)))
           (if (and c1 c2) (setq cl (cons c2 cl)))
         )
         (setq cl (reverse cl))
         (setq ss (ssadd))
         (foreach c (vl-remove nil (odd cl))
           (command "_.arc" (polar c (* pi -0.5) r) (polar c pi r) (polar c (* pi 0.5) r))
           (ssadd (entlast) ss)
         )
         (foreach c (vl-remove nil (even cl))
           (command "_.arc" (polar c (* pi -0.5) r) (polar c 0.0 r) (polar c (* pi 0.5) r))
           (ssadd (entlast) ss)
         )
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p (* pi 0.5) r)) (vl-remove nil (odd cl))) (mapcar '(lambda (p) (polar p (* pi -0.5) r)) (vl-remove nil (even cl))))
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p (* pi 0.5) r)) (vl-remove nil (even cl))) (mapcar '(lambda (p) (polar p (* pi -0.5) r)) (vl-remove nil (cdr (odd cl)))))
         (command "_.line" ip (polar (car cl) (* pi -0.5) r) "")
         (ssadd (entlast) ss)
       )
       (progn
         (command "_.offset" r lpl ip "")
         (setq lplo (entlast))
         (command "_.offset" r upl ip "")
         (setq uplo (entlast))
         (setq spc (vla-ObjectIdToObject *adoc* (vla-get-OwnerId (vlax-ename->vla-object lpl))))
         (setq c1 T c2 T k -3.0)
         (while (and c1 c2)
           (setq xl1 (vlax-invoke spc 'addxline (polar ip (* pi 0.5) (* r (setq k (+ k 4.0)))) (polar (polar ip (* pi 0.5) (* r k)) 0.0 1.0)))
           (setq c1 (vlax-invoke xl1 'intersectwith (vlax-ename->vla-object lplo) acextendnone))
           (vla-delete xl1)
           (setq xl2 (vlax-invoke spc 'addxline (polar ip (* pi 0.5) (* r (+ k 2.0))) (polar (polar ip (* pi 0.5) (* r (+ k 2.0))) 0.0 1.0)))
           (setq c2 (vlax-invoke xl2 'intersectwith (vlax-ename->vla-object uplo) acextendnone))
           (vla-delete xl2)
           (if c1 (setq cl (cons c1 cl)))
           (if (and c1 c2) (setq cl (cons c2 cl)))
         )
         (setq cl (reverse cl))
         (setq ss (ssadd))
         (foreach c (vl-remove nil (odd cl))
           (command "_.arc" (polar c (* pi -0.5) r) (polar c 0.0 r) (polar c (* pi 0.5) r))
           (ssadd (entlast) ss)
         )
         (foreach c (vl-remove nil (even cl))
           (command "_.arc" (polar c (* pi -0.5) r) (polar c pi r) (polar c (* pi 0.5) r))
           (ssadd (entlast) ss)
         )
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p (* pi 0.5) r)) (vl-remove nil (odd cl))) (mapcar '(lambda (p) (polar p (* pi -0.5) r)) (vl-remove nil (even cl))))
         (mapcar '(lambda (p1 p2) (progn (command "_.line" p1 p2 "") (ssadd (entlast) ss))) (mapcar '(lambda (p) (polar p (* pi 0.5) r)) (vl-remove nil (even cl))) (mapcar '(lambda (p) (polar p (* pi -0.5) r)) (vl-remove nil (cdr (odd cl)))))
         (command "_.line" ip (polar (car cl) (* pi -0.5) r) "")
         (ssadd (entlast) ss)
       )
     )
   )
 )
 (setvar 'peditaccept 1)
 (command "_.pedit" "m" ss "" "j" "" "")
 (entdel lplo)
 (entdel uplo)
 (setvar 'osmode osm)
 (setvar 'peditaccept pea)
 (command "_.ucs" "p")
 (princ)
)
(defun c:sf-2c nil (c:snakefill-2curveboundaries))
(prompt "\n...Run with 'SF-2C'...")
(princ)