Author Topic: Hatching islands between two polylines  (Read 7901 times)

0 Members and 1 Guest are viewing this topic.

GP

  • Newt
  • Posts: 82
  • Vercelli, Italy
Re: Hatching islands between two polylines
« Reply #15 on: February 17, 2014, 12:37:03 PM »
Thank you, Marko.  :-)

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #16 on: February 18, 2014, 12:49:28 PM »
Here is my interpretation of it.

General flow is I get the list of intersection between the polylines.

Then make sure that the direction of the intersection list is the same
as the reference polyline, otherwise reverse the intersection list.

Then get a midpoint from the distance on both polylines.

The midpoint of this 2 is internal. I use boundary to get the area
then hatch it.

Still have a problem when the polyline are closed.  I need to detect
when the distance goes over the lenght of the poly.

Here is the code:

Code - Auto/Visual Lisp: [Select]
  1. ;;; Cut & Fill      by ymg                                                    ;
  2. ;;;                                                                           ;
  3. ;;; Will return incorrect results if polyline are self-crossing.              ;
  4.  
  5.  
  6.  
  7. (defun c:cf (/ *acaddoc* ar cutcol cw cwi dm1 dm2 dp11 dp12 dp21 dp22 fillcol
  8.                fuzz hatchcol i intl objpol1 objpol2 p p1 p2 pm0 pm1 pm2 pol1
  9.                pol2 ss1 ss2 totcut totfill txt txtlayer valid varl)
  10.      
  11.  
  12.    (defun *error* (msg)
  13.         (mapcar 'eval varl)
  14.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
  15.            (princ (strcat "\nError: " msg))
  16.         )
  17.         (and *AcadDoc* (vla-endundomark *AcadDoc*))
  18.         (princ)
  19.    )
  20.      
  21.    (setq varl '("OSMODE" "CMDECHO" "DIMZIN")
  22.          varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
  23.    )
  24.    
  25.    (or *AcadDoc*
  26.    )
  27.      
  28.    (vla-startundomark *AcadDoc*)
  29.  
  30.    (setvar 'CMDECHO 0)
  31.    (setvar 'DIMZIN  0)
  32.    (setvar 'OSMODE  0)
  33.      
  34.  
  35.   (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                      ;
  36.         totcut 0  totfill 0  ; Total Cut and Total Fill                       ;
  37.           txtlayer "Text"    ; Name of Layer for Cut and Fill Values          ;
  38.          
  39.   )    
  40.   (princ "\nSelect Reference Polyline:")
  41.      (setq ss1 (ssget "_:S"))
  42.      (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
  43.           (princ "\nYou Must Select a Polyline:")
  44.           (setq ss1 (ssget "_:S"))
  45.      )
  46.  
  47.  (princ "\nSelect Proposed Polyline:")
  48.      (setq ss2 (ssget "_:S"))
  49.      (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
  50.           (princ "\nYou Must Select a Polyline:")
  51.           (setq ss2 (ssget "_:S"))
  52.      )
  53.      
  54.  
  55.   (setq pol1 (ssname ss1 0) objpol1 (vlax-ename->vla-object pol1)
  56.         pol2 (ssname ss2 0) objpol2 (vlax-ename->vla-object pol2)
  57.           cw (if (iscw_p (listpol pol1)) 1 -1)
  58.   )
  59.  
  60.  
  61.   ; Getting all the intersections between poly.                               ;
  62.  
  63.   (setq intl (intersections objpol1 objpol2))  
  64.  
  65.  
  66.   ; If polyline is closed add first Intersection to end of list               ;
  67.      
  68.      (setq intl (append intl (list (car intl))))
  69.   )
  70.  
  71.   ; Insure that Intersection List goes same direction as Reference Polyline.  ;
  72.   (setq cwi (if (iscw_p intl) 1 -1))
  73.   (if (/= cw cwi) (setq intl (reverse intl)))
  74.  
  75.   (setq  p1 (car intl)
  76.        dp11 (getdistoncurve pol1 p1)
  77.        dp21 (getdistoncurve pol2 p1)
  78.           i 1
  79.   )
  80.   (repeat (- (length intl) 1)
  81.      (setq valid t           
  82.               p2 (nth i intl)
  83.             dp12 (getdistoncurve pol1 p2)
  84.             dp22 (getdistoncurve pol2 p2)
  85.              dm1 (/ (+ dp11 dp12) 2)                        
  86.              dm2 (/ (+ dp21 dp22) 2)            
  87.              pm1 (getptoncurve pol1 dm1)             
  88.              pm2 (getptoncurve pol2 dm2)
  89.              pm0 (mapcar '/ (mapcar '+ pm1 pm2) '(2. 2.))  ; Internal Point   ;
  90.      )
  91.      (if (> (distance pm1 pm2) 0.00001)
  92.         (progn      
  93.             (vl-cmdf "._-BOUNDARY" pm0 "")
  94.             (setq ar (vla-get-area (vlax-ename->vla-object (entlast))))
  95.             (entdel (entlast))
  96.             (if (minusp (* (onside pm2 p1 pm1) cw))              
  97.                (setq totcut  (+ totcut  ar) hatchcol  cutcol)
  98.                (setq totfill (+ totfill ar) hatchcol fillcol)
  99.             )
  100.             ;(vl-cmdf "._POINT" pm0 "")
  101.             (vl-cmdf "._-HATCH" "_P" "SOLID" "_CO" hatchcol pm0 "")        
  102.         )
  103.      )
  104.      (setq   p1 p2
  105.            dp11 dp12
  106.            dp21 dp22
  107.               i (1+ i)
  108.      )
  109.   )
  110.      
  111.   (if valid
  112.       (progn
  113.           (setq   p (cadr (grread nil 13 0))
  114.                 txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
  115.           )      
  116.           (entmakex (list
  117.                       (cons 0 "MTEXT")
  118.                       (cons 100 "AcDbEntity")
  119.                       (cons 8 txtlayer)
  120.                       (cons 100 "AcDbMText")
  121.                       (cons 10 p)                
  122.                       (cons 40 3.0)
  123.                       (cons 1 txt)
  124.                     )
  125.           )          
  126.  
  127.           (command "_MOVE" (entlast) "" p pause)
  128.       )
  129.       (Alert "Not Enough Intersections To Process !")
  130.   )
  131.      
  132.   (*error* nil)
  133.      
  134. )
  135.  
  136. (princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
  137. (princ "\nCF to start...")
  138.  
  139.  
  140.  
  141. ; onside        by ymg                                                        ;
  142. ; Negative return, point is on right of v1->v2                                ;
  143. ; Positive return, point is on left  of v1->v2                                ;
  144. ;        0 return, point is smack on the vector.                              ;
  145. ;                                                                             ;
  146.  
  147. (defun onside (p v1 v2 / x y)
  148.     (setq x (car p) y (cadr p))
  149.     (- (* (- (car  v1) x) (- (cadr v2) y)) (* (- (cadr v1) y) (- (car  v2) x)))    
  150. )
  151.  
  152. ; is the polyline  clockwise.                by LeeMac                        ;
  153. (defun iscw_p (l)    
  154.     (minusp
  155.         (apply '+
  156.             (mapcar
  157.                 (function
  158.                     (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
  159.                 )
  160.                 l (cons (last l) l)
  161.             )
  162.         )
  163.     )
  164. )
  165.  
  166. ;;****************************************************************************;
  167. ;; Return list of intersection(s) between two objects                         ;
  168. ;; obj1 - first VLA-Object                                                    ;
  169. ;; obj2 - second VLA-Object                                                   ;
  170. ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  171. ;;                                acExtendOtherEntity acExtendBoth)           ;
  172. ;;****************************************************************************;
  173.      
  174. (defun Intersections (obj1 obj2)
  175.    (defun tupl3 (l) (if l (cons (list (car l) (cadr l) (caddr l))(tupl3 (cdddr l)))))
  176.    (tupl3 (vlax-invoke obj1 'intersectwith obj2 acExtendNone))          
  177. )
  178.  
  179.  
  180. (defun getdistoncurve (e p)
  181.              (vlax-curve-getclosestpointto e p)
  182.         )    
  183.    )         
  184. )
  185.  
  186. (defun getptoncurve (e d)
  187. )
  188.  
  189. ;;; listpol   by Gille Chanteau                                               ;
  190. ;;; Returns the vertices list of any type of polyline (WCS coordinates)       ;
  191. ;;;                                                                           ;
  192. ;;; Argument                                                                  ;
  193. ;;; en, a polyline (ename or vla-object)                                      ;
  194.  
  195. (defun listpol (en / i p l)  
  196.   (setq i (vlax-curve-getEndParam en) i (if (vlax-curve-IsClosed en) i (1+ i)))      
  197.       (setq l (cons (trans p 0 1 ) l))
  198.   )
  199. )
  200.  

sanju2323

  • Newt
  • Posts: 65
Re: Hatching islands between two polylines
« Reply #17 on: March 04, 2016, 03:04:00 AM »
Hello sir,
       your Lisp code is very useful for me. But I want to change slightly, to help me if you can. I want it, polyline in the corner of the hatch should arrive. Please see drawing for understanding.

Thank you
sanju

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #18 on: March 05, 2016, 12:08:12 PM »
Hello ymg
in some cases your lisp gives this error
Quote
A color number or standard color name is required.
Error: bad argument value: AcDbCurve 71
New background color [Truecolor/COlorbook/. (for none)] <None>: *Cancel*
any suggestion 

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #19 on: March 07, 2016, 05:44:05 AM »
motee-z,

It's a little vague as error description.

Maybe the intersections fails because you have very large coordinates.

If it is the case simply move your curve nearer to 0,0

ymg

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #20 on: March 07, 2016, 06:56:16 AM »
sanju23,

Uses mk-lwp to create a temporary polyline by adding startpoint and endpoint of reference poly to
the proposed poly.

From then on use that temporary poly as your proposed entity.

Code - Auto/Visual Lisp: [Select]
  1. ;;                                                                            ;
  2. ;; mk_lwp    by Alan J Thompson     (Modified by ymg for closed poly)         ;
  3. ;;                                                                            ;
  4. ;; Argument: pl, A list of points (2d or 3d)                                  ;
  5. ;; Create an LWPolyline at Elevation 0, on Current Layer.                     ;
  6. ;; Return: Polyline Object                                                    ;
  7. ;;                                                                            ;
  8.  
  9. (defun mk_lwp (pl / isclosed)
  10.    (setq isclosed 0)
  11.    (if (equal (car pl) (last pl) 0.001)
  12.       (setq isclosed 1 pl (cdr pl))
  13.    )
  14.    (vlax-ename->vla-object
  15.       (entmakex
  16.          (append  (list '(0 . "LWPOLYLINE")
  17.                         '(100 . "AcDbEntity")
  18.                         '(100 . "AcDbPolyline")
  19.                          (cons 90 (length pl))
  20.                          (cons 70 isclosed)
  21.                   )
  22.                   (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  23.          )
  24.       )
  25.    )
  26. )
  27.  
« Last Edit: March 07, 2016, 07:09:29 AM by ymg »

sanju2323

  • Newt
  • Posts: 65
Re: Hatching islands between two polylines
« Reply #21 on: March 07, 2016, 07:16:07 AM »
ymg,

       This code is very good., Thank you for the help.

sanju

Lee Mac

  • Seagull
  • Posts: 12390
  • London, England
Re: Hatching islands between two polylines
« Reply #22 on: March 07, 2016, 09:53:11 AM »
Code - Auto/Visual Lisp: [Select]
  1. ;;                                                                            ;
  2. ;; mk_lwp    by Alan J Thompson     (Modified by ymg for closed poly)         ;
  3. ;;                                                                            ;
  4. ;; Argument: pl, A list of points (2d or 3d)                                  ;
  5. ;; Create an LWPolyline at Elevation 0, on Current Layer.                     ;
  6. ;; Return: Polyline Object                                                    ;
  7. ;;                                                                            ;
  8.  
  9. (defun mk_lwp (pl / isclosed)
  10.    (setq isclosed 0)
  11.    (if (equal (car pl) (last pl) 0.001)
  12.       (setq isclosed 1 pl (cdr pl))
  13.    )
  14.    (vlax-ename->vla-object
  15.       (entmakex
  16.          (append  (list '(0 . "LWPOLYLINE")
  17.                         '(100 . "AcDbEntity")
  18.                         '(100 . "AcDbPolyline")
  19.                          (cons 90 (length pl))
  20.                          (cons 70 isclosed)
  21.                   )
  22.                   (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  23.          )
  24.       )
  25.    )
  26. )
  27.  

FWIW, For general purpose, I would suggest the following revision of your function, since LWPolyline vertices are defined relative to the OCS, with elevation determined by DXF group 38:
Code - Auto/Visual Lisp: [Select]
  1. (defun mk_lwp ( lst / cls ocs )
  2.     (if (setq cls (equal (car lst) (last lst) 1e-3))
  3.         (setq lst (cdr lst))
  4.     )
  5.     (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)
  6.           lst (mapcar '(lambda ( x ) (cons 10 (trans x 1 ocs))) lst)
  7.     )
  8.     (entmakex
  9.         (vl-list*
  10.            '(000 . "LWPOLYLINE")
  11.            '(100 . "AcDbEntity")
  12.            '(100 . "AcDbPolyline")
  13.             (cons 090 (length lst))
  14.             (cons 070 (if cls 1 0))
  15.             (cons 038 (car (cdddar lst)))
  16.             (cons 210 ocs)
  17.             lst
  18.         )
  19.     )
  20. )

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #23 on: March 07, 2016, 12:25:55 PM »
Lee,

For general purpose, I agree that your modification are a must.

In my use most of the time I need the poly at elv 0, and like to
have an object returned so I can invoke intersectwith.

The vl-list* is a nice modif.

I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.

Here with typo removed and a little mod for 2d:

Code - Auto/Visual Lisp: [Select]
  1. (defun mk_lwp ( l / cls ocs )
  2.     (if (setq cls (equal (car l) (last l) 1e-3))
  3.        (setq l (cdr l))
  4.     )
  5.     (entmakex
  6.         (vl-list*
  7.            '(000 . "LWPOLYLINE")
  8.            '(100 . "AcDbEntity")
  9.            '(100 . "AcDbPolyline")
  10.             (cons 090 (length lst))
  11.             (cons 070 (if cls 1 0))
  12.             (cons 038 (if (caddar l)(caddar l) 0))
  13.             (cons 210 (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)))
  14.             (mapcar '(lambda (a) (cons 10 (trans a 1 ocs))) l)          
  15.         )
  16.     )
  17. )
  18.  


« Last Edit: March 07, 2016, 01:14:58 PM by ymg »

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #24 on: March 07, 2016, 04:40:52 PM »
ymg no large coordinates this case happened when opening new drawing so i have to delete old polylines draw others then may be the lisp work

Lee Mac

  • Seagull
  • Posts: 12390
  • London, England
Re: Hatching islands between two polylines
« Reply #25 on: March 07, 2016, 05:52:57 PM »
I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.

There is no typo as far as I can see; trans will always return a 3D point.

Note that your modifications will cause the function to fail for a UCS whose origin elevation is not equal to that of the WCS origin.
« Last Edit: March 07, 2016, 06:54:02 PM by Lee Mac »

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #26 on: March 07, 2016, 07:05:02 PM »
thanks Lee for reply
there is no modification on ymg routin
i know where is the problem now after several tests
if i press enter twice after getting error then repeat the command on other polylines in this case it will work
but if i press escape after getting error the command will not work ever

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #27 on: March 07, 2016, 11:10:20 PM »
I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.

There is no typo as far as I can see; trans will always return a 3D point.

Note that your modifications will cause the function to fail for a UCS whose origin elevation is not equal to that of the WCS origin.

I think that you Lee first made mistake with (setq ocs (trans '(0.0 0.0 1.0) 1 0 t))... YMG just copied your version...

Something like this could do it...

Code - Auto/Visual Lisp: [Select]
  1. (defun mk_lwp ( l / v^v unit barycent ocs cls )
  2.  
  3.     (setq l (mapcar '(lambda ( p ) (trans p 1 0)) l))
  4.  
  5.     (defun v^v ( u v )
  6.         (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  7.         (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  8.         (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  9.     )
  10.  
  11.     (defun unit ( v )
  12.         (if (not (equal v '(0.0 0.0 0.0) 1e-6))
  13.             (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
  14.         )
  15.     )
  16.  
  17.     (defun barycent ( ptlst )
  18.         (mapcar '(lambda ( x ) (/ x (float (length ptlst))))
  19.             (mapcar '(lambda ( x ) (apply '+ x))
  20.                 (apply 'mapcar (cons 'list ptlst))
  21.             )
  22.         )
  23.     )
  24.  
  25.     (cond
  26.         ( (and (caddr l) (setq ocs (unit (v^v (mapcar '- (cadr l) (car l)) (mapcar '- (barycent l) (car l))))))
  27.         )
  28.         ( (and (cadr l) (not (equal (car l) (cadr l) 1e-6)) (setq ocs (unit (v^v '(1.0 0.0 0.0) (unit (mapcar '- (cadr l) (car l)))))))
  29.         )
  30.         ( (or (and (cadr l) (equal (car l) (cadr l) 1e-6)) (not (cadr l)))
  31.           (setq ocs '(0.0 0.0 1.0))
  32.         )
  33.     )
  34.     (if (setq cls (equal (car l) (last l) 1e-3))
  35.         (setq l (cdr l))
  36.     )
  37.     (entmakex
  38.         (vl-list*
  39.            '(000 . "LWPOLYLINE")
  40.            '(100 . "AcDbEntity")
  41.            '(100 . "AcDbPolyline")
  42.             (cons 090 (length lst))
  43.             (cons 070 (if cls (if (eq (getvar 'plinegen) 1) 129 1) (if (eq (getvar 'plinegen) 1) 128 0)))
  44.             (cons 038 (caddr (trans (car l) 0 ocs)))
  45.             (cons 210 ocs)
  46.             (mapcar '(lambda ( p ) (cons 10 (trans p 0 ocs))) l)          
  47.         )
  48.     )
  49. )
  50.  
« Last Edit: March 08, 2016, 02:20:04 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #28 on: March 13, 2016, 08:05:38 AM »
Here a bit better, the closed poly bug is resolved and so is
the problem with not answering the prompt for background color
when calling the hatch command.

Not completely sure that it works in every case, I might have to
rotate the vertices when we got closed polylines.

Code - Auto/Visual Lisp: [Select]
  1. ;;; Cut & Fill      by ymg                                                    ;
  2. ;;;                                                                           ;
  3.  
  4.  
  5.  
  6. (defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol
  7.                intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1
  8.                ss2 totcut totfill txt txtlayer varl)
  9.                
  10.  
  11.    (defun *error* (msg)
  12.         (mapcar 'eval varl)
  13.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
  14.            (princ (strcat "\nError: " msg))
  15.         )
  16.         (and *acdoc* (vla-endundomark *acdoc*))
  17.         (princ)
  18.    )
  19.  
  20.    (setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")
  21.          varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
  22.    )
  23.  
  24.    (or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))
  25.  
  26.    (vla-startundomark *acdoc*)
  27.  
  28.    (setvar 'CMDECHO 0)
  29.    (setvar 'DIMZIN  0)
  30.    (setvar 'OSMODE  0)
  31.  
  32.  
  33.    (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                     ;
  34.          totcut 0  totfill 0  ; Total Cut and Total Fill                      ;
  35.            txtlayer "Text"    ; Name of Layer for Cut and Fill Values         ;
  36.  
  37.    )
  38.    (while (not (setq **  (princ "\nSelect Reference Polyline:")
  39.                      ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  40.                )
  41.           )
  42.         (princ "\nYou Must Select a Polyline:")
  43.    )                  
  44.    (while (not (setq **  (princ "\nSelect Proposed Polyline:")
  45.                      ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  46.                )
  47.           )
  48.         (princ "\nYou Must Select a Polyline:")
  49.    )
  50.  
  51.      
  52.    (setq pol1 (ssname ss1 0)
  53.          len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))
  54.          pol2 (ssname ss2 0)
  55.          len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))
  56.          sp1  (vlax-curve-getstartpoint pol1)
  57.          spe  (vlax-curve-getendpoint pol1)
  58.          sp2  (vlax-curve-getstartpoint pol2)
  59.          dir  (direct sp1 spe)
  60.    )      
  61.    
  62.  
  63.    ; Getting all the intersections between poly.                              ;
  64.  
  65.    (setq intl (intersections pol1 pol2))
  66.  
  67.    (if (> (length intl) 1)
  68.       (progn
  69.    
  70.    ; Computing distance of intersections on each polyline                     ;
  71.    
  72.          (setq dl1  (mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)
  73.                dl2  (mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)
  74.          )
  75.    
  76.    ; If both polyline are closed add first Intersection to end of list        ;
  77.    ; We also add a distance to each distances list                            ;
  78.  
  79.          (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
  80.             (setq dl1  (append dl1 (list (+ (car dl1) len1)))
  81.                   dl2  (append dl2 (list (+ (car dl2) len2)))
  82.                   intl (append intl (list (car intl)))
  83.                   dir  (if (iscw_p (listpol pol1)) -1 1)    
  84.             )      
  85.          )
  86.    
  87.  
  88.    ; Finding points at mid-distance between intersections on each polyline    ;
  89.    ; Calculating midpoint between mid-distance points to get an internal point;
  90.    ; Creating a list of all these points plus the intersection points         ;
  91.    
  92.          (setq pm
  93.             (mapcar
  94.                 '(lambda (a b c d e)
  95.                     (list (midpoint
  96.                               (setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))
  97.                               (setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))
  98.                            )
  99.                            p1 p2 e            
  100.                      )
  101.                   )
  102.                   dl1 (cdr dl1) dl2 (cdr dl2) intl
  103.              )
  104.          )      
  105.  
  106.    
  107.    
  108.          (foreach i pm
  109.             (setq  p (car    i)  ; Midpoint between p1 p2                           ;
  110.                   p0 (cadddr i)  ; Intersection Point                               ;
  111.                   p1 (cadr   i)  ; Midpoint of Intersections on Reference Polyline  ;
  112.                   p2 (caddr  i)  ; Midpoint of Intersections on Proposed Polyline   ;
  113.             )
  114.             (if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear                     ;
  115.                (progn
  116.                   (vl-cmdf "._-BOUNDARY" p "")
  117.                   (setq are (vla-get-area (vlax-ename->vla-object (entlast)))
  118.                         bnd (entlast)
  119.                   )
  120.            
  121.                   (if (minusp (* (onside p2 p0 p1) dir))              
  122.                      (setq totfill (+ totfill are) hcol fillcol)
  123.                      (setq totcut  (+ totcut  are) hcol  cutcol)
  124.                   )
  125.                
  126.                   (vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")
  127.                   (entdel bnd)
  128.                )
  129.             )
  130.          )
  131.          (setq   p (cadr (grread nil 13 0))
  132.                txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
  133.          )       
  134.          (entmakex (list
  135.                       (cons 0 "MTEXT")
  136.                       (cons 100 "AcDbEntity")
  137.                       (cons 8 txtlayer)
  138.                       (cons 100 "AcDbMText")
  139.                       (cons 10 p)                
  140.                       (cons 40 3.0)
  141.                       (cons 1 txt)
  142.                     )
  143.          )           
  144.  
  145.          (command "_MOVE" (entlast) "" p pause)
  146.       )
  147.       (Alert "Not Enough Intersections To Process !")
  148.   )
  149.  
  150.   (*error* nil)
  151.  
  152. )
  153.  
  154. (princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
  155. (princ "\nCF to start...")
  156.  
  157.  
  158. (defun direct (p0 p1)
  159.    (if (< (/ pi 2) (angle p0 p1) (/ (* 3 pi) 2)) -1 1)
  160. )
  161.  
  162. (defun midpoint (p1 p2)
  163.    (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
  164. )
  165.  
  166. ; onside        by ymg                                                        ;
  167. ; Negative return, point is on left of v1->v2                                 ;
  168. ; Positive return, point is on right of v1->v2                                ;
  169. ;        0 return, point is smack on the vector.                              ;
  170. ;                                                                             ;
  171.  
  172. (defun onside (p v1 v2 / x y)
  173.     (setq x (car p) y (cadr p))
  174.     (- (* (- (cadr v1) y) (-  (car v2) x)) (* (- (car  v1) x) (- (cadr v2) y)))
  175. )
  176.  
  177. ;                                                                             ;
  178. ; Is Polyline Clockwise                      by LeeMac                        ;
  179. ;                                                                             ;
  180. ; Argument:   l,  Point List                                                  ;
  181. ; Returns:    t, Polyline is ClockWise                                        ;
  182. ;           nil, Polyline is CounterClockWise                                 ;
  183. ;                                                                             ;
  184.  
  185. (defun iscw_p (l)
  186.     (if (equal (car l) (last l) 1e-8) (setq l (cdr l)))
  187.     (minusp
  188.         (apply '+
  189.             (mapcar
  190.                 (function
  191.                   (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
  192.                 )
  193.                 l (cons (last l) l)
  194.             )
  195.         )
  196.     )
  197. )
  198.  
  199. ;;                                                                            ;
  200. ;; Return list of intersection(s) between two VLA-Object or two ENAME         ;
  201. ;; obj1 - first VLA-Object                                                    ;
  202. ;; obj2 - second VLA-Object                                                   ;
  203. ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  204. ;;                                acExtendOtherEntity acExtendBoth)           ;
  205. ;; Requires triplet                                                           ;
  206. ;;                                                                            ;
  207.  
  208. (defun Intersections (obj1 obj2)
  209.    (or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))
  210.    (or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))
  211.            
  212.    (triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
  213. )
  214.  
  215. ;;                                                                            ;
  216. ;; triplet, Separates a list into triplets of items.                          ;
  217. ;;                                                                            ;
  218.  
  219. (defun triplet (l)
  220.    (if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))
  221. )
  222.  
  223.  
  224. (defun getdistoncurve (e p)
  225.              (vlax-curve-getclosestpointto e p)
  226.         )    
  227.    )         
  228. )
  229.  
  230. (defun getptoncurve (e d)
  231. )
  232.  
  233. ;;                                                                            ;
  234. ;; listpol     by ymg    (Simplified a Routine by Gile Chanteau               ;
  235. ;;                                                                            ;
  236. ;; Parameter:  en,  Entity Name or Object Name of Any Type of Polyline        ;
  237. ;;                                                                            ;
  238. ;; Returns:    List of Points in Current UCS                                  ;
  239. ;;                                                                            ;
  240. ;; Notes:      On Closed Polyline the Last Vertex is Same as First)           ;
  241. ;;                                                                            ;
  242.  
  243. (defun listpol (en / i l)
  244.       (setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))
  245.    )
  246. )
  247.  

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #29 on: March 13, 2016, 11:54:20 AM »
Here I revised to change the origin of the proposed polyline
to the nearest vertex to the reference polyline start point.

Note that it could fail If we have long thin polyline.
Although it is quite unlikely in a tunnel.

Code - Auto/Visual Lisp: [Select]
  1. ;;; Cut & Fill      by ymg                                                    ;
  2. ;;;                                                                           ;
  3.  
  4.  
  5.  
  6. (defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol
  7.                intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1
  8.                ss2 totcut totfill txt txtlayer varl)
  9.                
  10.  
  11.    (defun *error* (msg)
  12.         (mapcar 'eval varl)
  13.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
  14.            (princ (strcat "\nError: " msg))
  15.         )
  16.         (and *acdoc* (vla-endundomark *acdoc*))
  17.         (princ)
  18.    )
  19.  
  20.    (setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")
  21.          varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
  22.    )
  23.  
  24.    (or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))
  25.  
  26.    (vla-startundomark *acdoc*)
  27.  
  28.    (setvar 'CMDECHO 0)
  29.    (setvar 'DIMZIN  0)
  30.    (setvar 'OSMODE  0)
  31.  
  32.  
  33.    (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                     ;
  34.          totcut 0  totfill 0  ; Total Cut and Total Fill                      ;
  35.            txtlayer "Text"    ; Name of Layer for Cut and Fill Values         ;
  36.  
  37.    )
  38.    (while (not (setq **  (princ "\nSelect Reference Polyline:")
  39.                      ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  40.                )
  41.           )
  42.         (princ "\nYou Must Select a Polyline:")
  43.    )                  
  44.    (while (not (setq **  (princ "\nSelect Proposed Polyline:")
  45.                      ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  46.                )
  47.           )
  48.         (princ "\nYou Must Select a Polyline:")
  49.    )
  50.  
  51.      
  52.    (setq pol1 (ssname ss1 0)
  53.          len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))
  54.          pol2 (ssname ss2 0)
  55.          len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))
  56.          sp1  (vlax-curve-getstartpoint pol1)
  57.          spe  (vlax-curve-getendpoint pol1)
  58.          sp2  (if (vlax-curve-isClosed pol2)
  59.                  (setq lst2 (listpol pol2)
  60.                        disl (mapcar '(lambda (a) (distance sp1 a)) lst2)
  61.                        **   (plineorg pol2 (nth (vl-position (apply 'min disl) disl) lst2))
  62.                  )
  63.                  (vlax-curve-getstartpoint pol2)
  64.                )  
  65.          dir  (if (< (/ pi 2) (angle sp1 spe) (/ (* 3 pi) 2)) -1 1)
  66.    )      
  67.    
  68.  
  69.    ; Getting all the intersections between poly.                              ;
  70.  
  71.    (setq intl (intersections pol1 pol2))
  72.  
  73.    (if (> (length intl) 1)
  74.       (progn
  75.    
  76.    ; Computing distance of intersections on each polyline                     ;
  77.    
  78.          (setq dl1  (mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)
  79.                dl2  (mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)
  80.          )
  81.    
  82.    ; If both polyline are closed add first Intersection to end of list        ;
  83.    ; We also add a distance to each distances list                            ;
  84.  
  85.          (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
  86.             (setq dl1  (append dl1 (list (+ (car dl1) len1)))
  87.                   dl2  (append dl2 (list (+ (car dl2) len2)))
  88.                   intl (append intl (list (car intl)))
  89.                   dir  (if (iscw_p (listpol pol1)) -1 1)    
  90.             )      
  91.          )
  92.    
  93.  
  94.    ; Finding points at mid-distance between intersections on each polyline    ;
  95.    ; Calculating midpoint between mid-distance points to get an internal point;
  96.    ; Creating a list of all these points plus the intersection points         ;
  97.    
  98.          (setq pm
  99.             (mapcar
  100.                 '(lambda (a b c d e)
  101.                     (list (midpoint
  102.                               (setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))
  103.                               (setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))
  104.                            )
  105.                            p1 p2 e            
  106.                      )
  107.                   )
  108.                   dl1 (cdr dl1) dl2 (cdr dl2) intl
  109.              )
  110.          )      
  111.  
  112.    
  113.    
  114.          (foreach i pm
  115.             (setq  p (car    i)  ; Midpoint between p1 p2                           ;
  116.                   p0 (cadddr i)  ; Intersection Point                               ;
  117.                   p1 (cadr   i)  ; Midpoint of Intersections on Reference Polyline  ;
  118.                   p2 (caddr  i)  ; Midpoint of Intersections on Proposed Polyline   ;
  119.             )
  120.             (if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear                     ;
  121.                (progn
  122.                   (vl-cmdf "._-BOUNDARY" p "")
  123.                   (setq are (vla-get-area (vlax-ename->vla-object (entlast)))
  124.                         bnd (entlast)
  125.                   )
  126.            
  127.                   (if (minusp (* (onside p2 p0 p1) dir))              
  128.                      (setq totfill (+ totfill are) hcol fillcol)
  129.                      (setq totcut  (+ totcut  are) hcol  cutcol)
  130.                   )
  131.                
  132.                   (vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")
  133.                   (entdel bnd)
  134.                )
  135.             )
  136.          )
  137.          (setq   p (cadr (grread nil 13 0))
  138.                txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
  139.          )       
  140.          (entmakex (list
  141.                       (cons 0 "MTEXT")
  142.                       (cons 100 "AcDbEntity")
  143.                       (cons 8 txtlayer)
  144.                       (cons 100 "AcDbMText")
  145.                       (cons 10 p)                
  146.                       (cons 40 3.0)
  147.                       (cons 1 txt)
  148.                     )
  149.          )           
  150.  
  151.          (command "_MOVE" (entlast) "" p pause)
  152.       )
  153.       (Alert "Not Enough Intersections To Process !")
  154.   )
  155.  
  156.   (*error* nil)
  157.  
  158. )
  159.  
  160. (princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
  161. (princ "\nCF to start...")
  162.  
  163.  
  164.  
  165. (defun midpoint (p1 p2)
  166.    (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
  167. )
  168.  
  169. ; onside        by ymg                                                        ;
  170. ; Negative return, point is on left of v1->v2                                 ;
  171. ; Positive return, point is on right of v1->v2                                ;
  172. ;        0 return, point is smack on the vector.                              ;
  173. ;                                                                             ;
  174.  
  175. (defun onside (p v1 v2 / x y)
  176.     (setq x (car p) y (cadr p))
  177.     (- (* (- (cadr v1) y) (-  (car v2) x)) (* (- (car  v1) x) (- (cadr v2) y)))
  178. )
  179.  
  180. ;                                                                             ;
  181. ; Is Polyline Clockwise                      by LeeMac                        ;
  182. ;                                                                             ;
  183. ; Argument:   l,  Point List                                                  ;
  184. ; Returns:    t, Polyline is ClockWise                                        ;
  185. ;           nil, Polyline is CounterClockWise                                 ;
  186. ;                                                                             ;
  187.  
  188. (defun iscw_p (l)
  189.     (if (equal (car l) (last l) 1e-8) (setq l (cdr l)))
  190.     (minusp
  191.         (apply '+
  192.             (mapcar
  193.                 (function
  194.                   (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
  195.                 )
  196.                 l (cons (last l) l)
  197.             )
  198.         )
  199.     )
  200. )
  201.  
  202. ;;                                                                            ;
  203. ;; Return list of intersection(s) between two VLA-Object or two ENAME         ;
  204. ;; obj1 - first VLA-Object                                                    ;
  205. ;; obj2 - second VLA-Object                                                   ;
  206. ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  207. ;;                                acExtendOtherEntity acExtendBoth)           ;
  208. ;; Requires triplet                                                           ;
  209. ;;                                                                            ;
  210.  
  211. (defun Intersections (obj1 obj2)
  212.    (or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))
  213.    (or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))
  214.            
  215.    (triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
  216. )
  217.  
  218. ;;                                                                            ;
  219. ;; triplet, Separates a list into triplets of items.                          ;
  220. ;;                                                                            ;
  221.  
  222. (defun triplet (l)
  223.    (if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))
  224. )
  225.  
  226.  
  227. (defun getdistoncurve (e p)
  228.              (vlax-curve-getclosestpointto e p)
  229.         )    
  230.    )         
  231. )
  232.  
  233. (defun getptoncurve (e d)
  234. )
  235.  
  236. ;;                                                                            ;
  237. ;; listpol     by ymg    (Simplified a Routine by Gile Chanteau               ;
  238. ;;                                                                            ;
  239. ;; Parameter:  en,  Entity Name or Object Name of Any Type of Polyline        ;
  240. ;;                                                                            ;
  241. ;; Returns:    List of Points in Current UCS                                  ;
  242. ;;                                                                            ;
  243. ;; Notes:      On Closed Polyline the Last Vertex is Same as First)           ;
  244. ;;                                                                            ;
  245.  
  246. (defun listpol (en / i l)
  247.       (setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))
  248.    )
  249. )
  250.  
  251.  
  252. ;; plineorg   by (gile) (Modified into a function by ymg)                     ;
  253. ;;  https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/          ;
  254. ;;            change-polyline-start-point/td-p/2154331                        ;
  255. ;;                                                                            ;
  256. ;; Function to modify origin of a closed polyline                             ;
  257. ;;                                                                            ;
  258. ;; Arguments:                                                                 ;
  259. ;;   en : Ename or VLA-Object of a Closed Polyline.                           ;
  260. ;;   pt : Point                                                               ;
  261. ;;                                                                            ;
  262. ;; Returns: Point of Origin if successful, else nil.                          ;
  263. ;;                                                                            ;
  264.  
  265. (defun plineorg (en pt / blst d1 d2 d3 n norm obj pa plst)
  266.    (if (= (type en) 'ENAME)
  267.       (setq obj (vlax-ename->vla-object  en))
  268.       (setq obj en   en (vlax-vla-object->ename obj))
  269.    )
  270.    
  271.     ;; bulgratio   by (gile)                                 ;
  272.     ;; Returns a bulge which is proportional to a reference  ;
  273.     ;; Arguments :                                           ;
  274.     ;; b : the reference bulge                               ;
  275.     ;; k : the ratio (between angles or arcs length)         ;
  276.  
  277.    (defun bulgratio (b k / a)
  278.       (setq a (atan b))
  279.       (/ (sin (* k a)) (cos (* k a)))
  280.    )
  281.  
  282.     ;; Sublist  by (gile)                                    ;
  283.     ;; Returns a sublist similar to substr function.         ;
  284.     ;; lst : List from which sublist is to be extracted      ;
  285.     ;; idx : Index of Item at Start of sublist               ;
  286.     ;; len : Length of sublist or nil to return all items.   ;
  287.  
  288.    (defun sublist (lst n len / rtn)
  289.       (if (or (not len) (< (- (length lst) n) len))
  290.          (setq len (- (length lst) n))
  291.       )
  292.       (setq n (+ n len))
  293.       (repeat len
  294.          (setq rtn (cons (nth (setq n (1- n)) lst) rtn))
  295.       )
  296.    )
  297.  
  298.    (if (and (= (vla-get-closed obj) :vlax-true)
  299.             (= (vla-get-objectname obj) "AcDbPolyline")
  300.        )    
  301.       (progn
  302.          (setq plst (vlax-get obj 'coordinates)
  303.                norm (vlax-get obj 'normal)
  304.                pt   (vlax-curve-getClosestPointTo en (trans pt 1 0))
  305.                pa   (vlax-curve-getparamatpoint obj pt)
  306.                n    (/ (length plst) 2)        
  307.          )
  308.          (repeat n
  309.             (setq blst (cons (vla-getbulge obj (setq n (1- n))) blst))
  310.          )
  311.          (if (= pa (fix pa))
  312.             (setq n    (fix pa)
  313.                   plst (append (sublist plst (* 2 n) nil)
  314.                                (sublist plst 0 (* 2 n))
  315.                        )
  316.                   blst (append (sublist blst n nil) (sublist blst 0 n))
  317.             )
  318.             (setq n    (1+ (fix pa))
  319.                   d3   (vlax-curve-getdistatparam en n)
  320.                   d2   (- d3 (vlax-curve-getdistatpoint en pt))
  321.                   d3   (- d3 (vlax-curve-getdistatparam en (1- n)))
  322.                   d1   (- d3 d2)
  323.                   pt   (trans pt 0 (vlax-get obj 'normal))
  324.                   plst (append (list (car pt) (cadr pt))
  325.                                (sublist plst (* 2 n) nil)
  326.                                (sublist plst 0 (* 2 n))
  327.                        )
  328.                   blst (append (list (bulgratio (nth (1- n) blst) (/ d2 d3)))
  329.                                (sublist blst n nil)
  330.                                (sublist blst 0 (1- n))
  331.                                (list (bulgratio (nth (1- n) blst) (/ d1 d3)))
  332.                        )
  333.             )
  334.          )
  335.          (vlax-put obj 'coordinates plst)
  336.          (repeat (setq n (length blst))
  337.             (vla-setbulge obj (setq n (1- n)) (nth n blst))
  338.          )
  339.          (trans pt 0 1)
  340.       )
  341.       nil
  342.    )
  343. )
  344.