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

0 Members and 1 Guest are viewing this topic.

ur_naz

  • Newt
  • Posts: 68
  • Made in Ukraine
Hatching islands between two polylines
« on: September 13, 2013, 11:49:50 AM »
Hello, World! At first sorry for my poor English...
I have two polylines,  which are intersecting each other. The base one is green. Another one is red, generated by my program. So I need to hatch the islands between them in yellow hatch if red pline is above green one and in blue hatch when red pline is below green one.
Is it simple routine to do that? Thanks!

The first image is what i need
The second image is what i have
« Last Edit: September 13, 2013, 12:53:30 PM by ur_naz »

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Hatching islands between two polylines
« Reply #1 on: September 13, 2013, 12:08:57 PM »
Welcome.

Have you tried the -.hatch command in a lisp?
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ur_naz

  • Newt
  • Posts: 68
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #2 on: September 13, 2013, 12:22:24 PM »
I know this. The problem to me is how to determine internal points of islands to apply hatch command :embarrassed:

LE3

  • Guest
Re: Hatching islands between two polylines
« Reply #3 on: September 13, 2013, 12:35:14 PM »
... I am curios, can you post an image sample with those two plines ---- **the before**

ur_naz

  • Newt
  • Posts: 68
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #4 on: September 13, 2013, 12:49:38 PM »
it my fail, but i had uploaded 'hatch.dwg' with my two plines in 1st post.  you can remove all hatch from this file to see *the before* condition  :wink:

ymg

  • Guest
Re: Hatching islands between two polylines
« Reply #5 on: September 13, 2013, 12:54:59 PM »
Alanjt has something for getting all intersections between 2 polylines in this thread.

 
Label Contours

LeeMac, has something similar on his pages.

You could apply it to your problem.

ymg

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #6 on: September 13, 2013, 01:22:12 PM »
Yes, Lee has intersection functions...

Look here :
http://www.lee-mac.com/intersectionfunctions.html

And if you really want to program this function, I suggest that you recreate each boundary for hatching individually... You just have to reconstruct boundary polyline based on PlPath between 2 adjacent intersection points firstly on red and then on green polyline and join 2 PlPaths... Hatching will be processed alternative above ground then below ground, then again above ground then below ground and so on to the end... Although I strongly think this is better and more reliably doing it manually if you really want routine you'll have to construct it on your own as this programming is time consuming...

For PlPath.lsp look here :
http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page3&highlight=PlPath&p=#22

This is the way I would approach to this problem, I am not offering only solution, maybe there is more elegant way to accomplish this task... Maybe really internal points for islands, but I think this will lead to unreliably ways...

Just thinking loud...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ur_naz

  • Newt
  • Posts: 68
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #7 on: September 13, 2013, 01:54:05 PM »
Intersections! It must be a good idea! For each pair of intersection points finding pline parameters for both plines, getting middle parameters, getting points at parameter, getting middle point, applying hatch command. I need much more brain to write such code tonight  :-o Thanx you all

GP

  • Newt
  • Posts: 83
  • Vercelli, Italy
Re: Hatching islands between two polylines
« Reply #8 on: September 14, 2013, 07:58:03 AM »
Try, to be completed with the error handling.
 
Code: [Select]
;;; Hatch between two polylines.
;;; Gian Paolo Cattaneo - 14.09.2013
(defun c:TesT ( / cmd e3 e3_ e3p e3p_ npar p_vert ListaV ListaVp LPint contorno_trat)
    (or cal (arxload "geomcal"))
    (vl-load-com)
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (command "_.undo" "_begin")
    (if (and
            (setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
            (setq e3_ (vlax-ename->vla-object e3))
            (vl-position (vlax-get e3_ 'ObjectName) '("AcDbPolyline" "AcDb2dPolyline" ))
            (not (redraw e3 3))
            (setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
            (setq e3p_ (vlax-ename->vla-object e3p))
            (vl-position (vlax-get e3p_ 'ObjectName) '("AcDbPolyline" "AcDb2dPolyline" ))
            (not (redraw e3 4))
            (not (eq e3 e3p))
        )
        (progn
            ;;; poly1
            (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
                (setq p_vert (vlax-curve-getpointatparam e3 (setq n_par (1- n_par))))
                (setq ListaV (cons p_vert ListaV))
            )
            (if (> (car (car ListaV)) (car (last ListaV))) (setq ListaV (reverse ListaV)))     
            ;;; poly2
            (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
                (setq p_vert (vlax-curve-getpointatparam e3p (setq n_par (1- n_par))))
                (setq ListaVp (cons p_vert ListaVp))
            )   
            (if (> (car (car ListaVp)) (car (last ListaVp))) (setq ListaVp (reverse ListaVp)))   
            (lista_punti_intersezione)
            (repeat (1- (length LPint))
                (setq p- (car LPint))
                (setq p+ (cadr LPint))
                (calcolo_contorno_tratteggio)
                (calcolo_tipo_area)
                (disegno_hatch)
                (setq LPint (cdr LPint))
            )
        )
    )
    (prompt "\n ") (prompt "\n ")
    (command "_.undo" "_end")
    (setvar 'cmdecho cmd)
   
    (princ)
)
;;; Returns the intersection points of polylines.
(defun lista_punti_intersezione (/ INT)
    (setq INT (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
    (if INT
 (progn   
     (repeat (/ (length INT) 3)
  (setq LPint (cons (list (car INT)(cadr INT)(caddr INT)) LPint))
         (setq INT (cdddr INT))
     )
            ;Sort the list from left to right
            (setq LPint
           (vl-sort LPint
        (function (lambda (x1 x2) (< (car x1) (car x2))))
            )     )
 )
    )
    (if (< (length LPint) 2)
 (progn
     (alert "The polylines do not intersect in at least two points.")
     (exit)
    )    )   
)
;;; Returns a list of boundary points of the area to be hatched
(defun calcolo_contorno_tratteggio (/ x P_trat_esist P_trat_prog Dp- Dp+ )
    ;First polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3 p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3 p+))
    (mapcar
        '(lambda (x) (if (and
                             (> (vlax-curve-getDistAtPoint e3 x) 1e-6)       
                             (> (vlax-curve-getDistAtPoint e3 x) Dp-)
                             (< (vlax-curve-getDistAtPoint e3 x) Dp+)
    )   
                  (setq P_trat_esist (cons x P_trat_esist))
  )           )
  ListaV
    )
    (setq P_trat_esist (reverse P_trat_esist)) 
    ;Second polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3p p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3p p+)) 
    (mapcar
        '(lambda (x) (if (and
                             (> (vlax-curve-getDistAtPoint e3p x) 1e-6)
                             (> (vlax-curve-getDistAtPoint e3p x) Dp-)
                             (< (vlax-curve-getDistAtPoint e3p x) Dp+)
    )   
                  (setq P_trat_prog (cons x P_trat_prog))
  )           )
  ListaVp
    )
    (setq P_trat_prog (reverse P_trat_prog))   
    ;Hatch boundary
    (setq contorno_trat (append (cons p- P_trat_esist) (list p+)))   
    (repeat (setq n (length P_trat_prog))
 (setq contorno_trat (append contorno_trat (list (nth (setq n (1- n)) P_trat_prog))))
    )
)
;;;Return the hatch color
(defun calcolo_tipo_area (/ p_sx apex p_esist p_prog)
    (setq p_sx (list (- (car p-) 1.0) (cadr p-)))
    (setq apex p-)
    (setq p_esist (cadr contorno_trat))
    (setq p_prog (last contorno_trat))
    (if (> (cal "ang (apex, p_sx, p_esist)") (cal "ang (apex, p_sx, p_prog)"))
 (setq col 4) (setq col 2)
    )
   
)
;;;Hatch
(defun disegno_hatch (/ i hatch_def)
    (setq contorno_trat (cons (last contorno_trat) contorno_trat))
    (setq hatch_def (list
   '(0 . "HATCH")
   '(100 . "AcDbEntity")
   '(67 . 0)
   '(410 . "Model")
                        (cons 62 col)
   '(100 . "AcDbHatch")
   '(10 0.0 0.0 0.0)
   '(210 0.0 0.0 1.0)
   '(2 . "SOLID")
   '(70 . 1)
   '(71 . 0)
   '(91 . 1)
   '(92 . 1)
   (cons 93 (1- (length contorno_trat)))
    )               )
    (repeat (setq i (1- (length contorno_trat)))
 (setq hatch_def
                 (append
                     hatch_def
                     (list '(72 . 1))
                     (list (cons 10 (nth i contorno_trat)))
                     (list (cons 11 (nth (setq i (1- i)) contorno_trat)))
                 )
        )
    )
    (setq hatch_def
             (append
                 hatch_def
                 (list '(97 . 0))
                 (list '(75 . 0))
                 (list '(76 . 1))
                 (list '(98 . 1))
                 (list '(10 0.0 0.0 0.0))
                 (list '(470 . "LINEAR"))
             )
    )
    (entmake hatch_def)
    (command "_.draworder" (entlast) "" "_b")
)
 

ymg

  • Guest
Re: Hatching islands between two polylines
« Reply #9 on: September 14, 2013, 12:19:05 PM »
Molto buono! Gian Paolo,

In fact the same basic routine could be used to calculates surfaces on a cross section.

ymg

WILL HATCH

  • Bull Frog
  • Posts: 450
Re: Hatching islands between two polylines
« Reply #10 on: September 14, 2013, 08:20:29 PM »
very neat routine,  found a place where it doesn't work properly though

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #11 on: September 15, 2013, 02:54:50 AM »
This one is slightly better, but all credits to Gian Paolo Cattaneo...

No need to call (geomcal.arx) - added (ListClockwise-p) subfunction for checking side of boundary polylines and assign correct color... Also added error handler - really simple one, and also make better formatting of code - it's more readable... Also checked for unlocalized variables n_par instead of npar and p- and p+...

Code - Auto/Visual Lisp: [Select]
  1. ;;; Hatch between two polylines.
  2. ;;; Gian Paolo Cattaneo - 14.09.2013
  3. ;;; Marko Ribar modified - 15.09.2013
  4. (defun c:TesT (/        *error*  cmd      e3       e3_      e3p
  5.                e3p_     n_par    p_vert   ListaV   ListaVp  LPint
  6.                contorno_trat     p+       p-       adoc
  7.               )
  8.  
  9.  
  10.   (defun *error* (msg)
  11.     (if adoc
  12.       (vla-endundomark adoc)
  13.     )
  14.     (if cmd
  15.       (setvar 'cmdecho cmd)
  16.     )
  17.     (if msg
  18.       (prompt msg)
  19.     )
  20.     (princ)
  21.   )
  22.  
  23.   (setq cmd (getvar 'cmdecho))
  24.   (setvar 'cmdecho 0)
  25.   (if (and
  26.         (setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
  27.         (setq e3_ (vlax-ename->vla-object e3))
  28.         (vl-position
  29.           (vlax-get e3_ 'ObjectName)
  30.           '("AcDbPolyline" "AcDb2dPolyline")
  31.         )
  32.         (not (redraw e3 3))
  33.         (setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
  34.         (setq e3p_ (vlax-ename->vla-object e3p))
  35.         (vl-position
  36.           (vlax-get e3p_ 'ObjectName)
  37.           '("AcDbPolyline" "AcDb2dPolyline")
  38.         )
  39.         (not (redraw e3 4))
  40.         (not (eq e3 e3p))
  41.       )
  42.     (progn
  43. ;;; poly1
  44.       (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
  45.         (setq p_vert
  46.                (vlax-curve-getpointatparam e3 (setq n_par (1- n_par)))
  47.         )
  48.         (setq ListaV (cons p_vert ListaV))
  49.       )
  50.       (if (> (car (car ListaV)) (car (last ListaV)))
  51.         (setq ListaV (reverse ListaV))
  52.       )
  53. ;;; poly2
  54.       (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
  55.         (setq p_vert (vlax-curve-getpointatparam
  56.                        e3p
  57.                        (setq n_par (1- n_par))
  58.                      )
  59.         )
  60.         (setq ListaVp (cons p_vert ListaVp))
  61.       )
  62.       (if (> (car (car ListaVp)) (car (last ListaVp)))
  63.         (setq ListaVp (reverse ListaVp))
  64.       )
  65.       (lista_punti_intersezione)
  66.       (repeat (1- (length LPint))
  67.         (setq p- (car LPint))
  68.         (setq p+ (cadr LPint))
  69.         (calcolo_contorno_tratteggio)
  70.         (calcolo_tipo_area)
  71.         (disegno_hatch)
  72.         (setq LPint (cdr LPint))
  73.       )
  74.     )
  75.   )
  76.   (prompt "\n ")
  77.   (prompt "\n ")
  78.   (*error* nil)
  79.  
  80.   (princ)
  81. )
  82. ;;; Returns the intersection points of polylines.
  83. (defun lista_punti_intersezione (/ int)
  84.   (setq int (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
  85.   (if int
  86.     (progn
  87.       (repeat (/ (length int) 3)
  88.         (setq
  89.           LPint (cons (list (car int) (cadr int) (caddr int)) LPint)
  90.         )
  91.         (setq int (cdddr int))
  92.       )
  93.                                         ;Sort the list from left to right
  94.       (setq LPint
  95.              (vl-sort LPint
  96.                       (function (lambda (x1 x2) (< (car x1) (car x2))))
  97.              )
  98.       )
  99.     )
  100.   )
  101.   (if (< (length LPint) 2)
  102.     (progn
  103.       (alert
  104.         "The polylines do not intersect in at least two points."
  105.       )
  106.       (exit)
  107.     )
  108.   )
  109. )
  110. ;;; Returns a list of boundary points of the area to be hatched
  111. (defun calcolo_contorno_tratteggio
  112.        (/ x P_trat_esist P_trat_prog Dp- Dp+)
  113.                                         ;First polyline
  114.   (mapcar
  115.     '(lambda (x)
  116.        (if (and
  117.              (> (vlax-curve-getDistAtPoint e3 x) 1e-6)
  118.              (> (vlax-curve-getDistAtPoint e3 x) Dp-)
  119.              (< (vlax-curve-getDistAtPoint e3 x) Dp+)
  120.            )
  121.          (setq P_trat_esist (cons x P_trat_esist))
  122.        )
  123.      )
  124.     ListaV
  125.   )
  126.   (setq P_trat_esist (reverse P_trat_esist))
  127.                                         ;Second polyline
  128.   (mapcar
  129.     '(lambda (x)
  130.        (if (and
  131.              (> (vlax-curve-getDistAtPoint e3p x) 1e-6)
  132.              (> (vlax-curve-getDistAtPoint e3p x) Dp-)
  133.              (< (vlax-curve-getDistAtPoint e3p x) Dp+)
  134.            )
  135.          (setq P_trat_prog (cons x P_trat_prog))
  136.        )
  137.      )
  138.     ListaVp
  139.   )
  140.   (setq P_trat_prog (reverse P_trat_prog))
  141.                                         ;Hatch boundary
  142.   (setq contorno_trat (append (cons p- P_trat_esist) (list p+)))
  143.   (repeat (setq n (length P_trat_prog))
  144.     (setq contorno_trat
  145.            (append contorno_trat
  146.                    (list (nth (setq n (1- n)) P_trat_prog))
  147.            )
  148.     )
  149.   )
  150. )
  151. ;;;ListClockwise-p
  152. (defun ListClockwise-p (lst / z vlst)
  153.   (vl-catch-all-apply
  154.     'minusp
  155.     (list
  156.       (if
  157.         (not
  158.           (equal 0.0
  159.                  (setq z
  160.                         (apply '+
  161.                                (mapcar
  162.                                  (function
  163.                                    (lambda (u v)
  164.                                      (- (* (car u) (cadr v)) (* (car v) (cadr u)))
  165.                                    )
  166.                                  )
  167.                                  (setq vlst
  168.                                         (mapcar
  169.                                           (function
  170.                                             (lambda (a b) (mapcar '- b a))
  171.                                           )
  172.                                           (mapcar (function (lambda (x) (car lst))) lst)
  173.                                           (cdr (reverse (cons (car lst) (reverse lst))))
  174.                                         )
  175.                                  )
  176.                                  (cdr (reverse (cons (car vlst) (reverse vlst))))
  177.                                )
  178.                         )
  179.                  )
  180.                  1e-6
  181.           )
  182.         )
  183.          z
  184.          (progn
  185.            (prompt
  186.              "\n\nChecked vectors are colinear - unable to determine clockwise-p of list"
  187.            )
  188.            nil
  189.          )
  190.       )
  191.     )
  192.   )
  193. )
  194. ;;;Return the hatch color
  195. (defun calcolo_tipo_area nil
  196.   (if (ListClockwise-p contorno_trat)
  197.     (setq col 4)
  198.     (setq col 2)
  199.   )
  200. )
  201. ;;;Hatch
  202. (defun disegno_hatch (/ i hatch_def)
  203.   (setq contorno_trat (cons (last contorno_trat) contorno_trat))
  204.   (setq hatch_def (list
  205.                     '(0 . "HATCH")
  206.                     '(100 . "AcDbEntity")
  207.                     '(67 . 0)
  208.                     '(410 . "Model")
  209.                     (cons 62 col)
  210.                     '(100 . "AcDbHatch")
  211.                     '(10 0.0 0.0 0.0)
  212.                     '(210 0.0 0.0 1.0)
  213.                     '(2 . "SOLID")
  214.                     '(70 . 1)
  215.                     '(71 . 0)
  216.                     '(91 . 1)
  217.                     '(92 . 1)
  218.                     (cons 93 (1- (length contorno_trat)))
  219.                   )
  220.   )
  221.   (repeat (setq i (1- (length contorno_trat)))
  222.     (setq hatch_def
  223.            (append
  224.              hatch_def
  225.              (list '(72 . 1))
  226.              (list (cons 10 (nth i contorno_trat)))
  227.              (list (cons 11 (nth (setq i (1- i)) contorno_trat)))
  228.            )
  229.     )
  230.   )
  231.   (setq hatch_def
  232.          (append
  233.            hatch_def
  234.            (list '(97 . 0))
  235.            (list '(75 . 0))
  236.            (list '(76 . 1))
  237.            (list '(98 . 1))
  238.            (list '(10 0.0 0.0 0.0))
  239.            (list '(470 . "LINEAR"))
  240.          )
  241.   )
  242.   (entmake hatch_def)
  243.   (command "_.draworder" (entlast) "" "_b")
  244. )
  245.  

Invoke with : Command: TesT
« Last Edit: February 17, 2014, 05:31:09 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ur_naz

  • Newt
  • Posts: 68
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #12 on: September 15, 2013, 04:28:25 PM »
hello,  guys!  :-) Thank you for reply. Unfortunately my alorithm is not working in acad, however it's works in bricscad perfectly. So I'll try to undersrand on how your examples works.

GP

  • Newt
  • Posts: 83
  • Vercelli, Italy
Re: Hatching islands between two polylines
« Reply #13 on: September 16, 2013, 01:11:46 PM »
Molto buono! Gian Paolo,

Grazie, ymg.  :)
 
 
No need to call (geomcal.arx) - added (ListClockwise-p) subfunction for checking side of boundary polylines and assign correct color... Also added error handler - really simple one, and also make better formatting of code - it's more readable... Also checked for unlocalized variables n_par instead of npar and p- and p+...

Great job, Marko.
 
 
...found a place where it doesn't work properly though

Because the green polyline is drawn from right to left.
 
Updated code:
Code: [Select]
;;; Hatch between two polylines.
;;;
;;; Gian Paolo Cattaneo  - 14.09.2013
;;;
;;; Marko Ribar modified - 15.09.2013
;;;
;;; Gian Paolo Cattaneo  - 16.09.2013
;;; Fixed a bug for polylines drawn from right to left.
;;;
;;;
(defun c:TesT (/        *error*  cmd      e3       e3_      e3p
               e3p_     n_par    p_vert   ListaV   ListaVp  LPint
               contorno_trat     p+       p-       adoc
               inv_p1   inv_p2
              )
    (vl-load-com)
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    (defun *error* (msg)
        (if adoc
            (vla-endundomark adoc)
        )
        (if cmd
            (setvar 'cmdecho cmd)
        )
        (if msg
            (prompt msg)
        )
        (princ)
    )
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (vla-startundomark adoc)
    (if (and
            (setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
            (setq e3_ (vlax-ename->vla-object e3))
            (vl-position
                (vlax-get e3_ 'ObjectName)
                '("AcDbPolyline" "AcDb2dPolyline")
            )
            (not (redraw e3 3))
            (setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
            (setq e3p_ (vlax-ename->vla-object e3p))
            (vl-position
                (vlax-get e3p_ 'ObjectName)
                '("AcDbPolyline" "AcDb2dPolyline")
            )
            (not (redraw e3 4))
            (not (eq e3 e3p))
        )
        (progn
            ;;; poly1
            (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
                (setq p_vert
                         (vlax-curve-getpointatparam
                             e3
                             (setq n_par (1- n_par))
                         )
                )
                (setq ListaV (cons p_vert ListaV))
            )
            (if (> (car (car ListaV)) (car (last ListaV)))
                (progn
                    (setq ListaV (reverse ListaV))
                    (setq inv_p1 t)
                )
            )
            ;;; poly2
            (repeat
                (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
                   (setq p_vert (vlax-curve-getpointatparam
                                    e3p
                                    (setq n_par (1- n_par))
                                )
                   )
                   (setq ListaVp (cons p_vert ListaVp))
            )
            (if (> (car (car ListaVp)) (car (last ListaVp)))
                (progn
                    (setq ListaVp (reverse ListaVp))
                    (setq inv_p2 t)
                )
            )
            (lista_punti_intersezione)
            (repeat (1- (length LPint))
                (setq p- (car LPint))
                (setq p+ (cadr LPint))
                (calcolo_contorno_tratteggio)
                (calcolo_tipo_area)
                (disegno_hatch)
                (setq LPint (cdr LPint))
            )
        )
    )
    (prompt "\n ")
    (prompt "\n ")
    (*error* nil)
    (princ)
)
;;; Returns the intersection points of polylines.
(defun lista_punti_intersezione (/ int)
    (setq int (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
    (if int
        (progn
            (repeat (/ (length int) 3)
                (setq
                    LPint
                       (cons (list (car int) (cadr int) (caddr int))
                             LPint
                       )
                )
                (setq int (cdddr int))
            )
            ;Sort the list from left to right
            (setq LPint
                     (vl-sort LPint
                              (function (lambda (x1 x2) (< (car x1) (car x2))))
                     )
            )
        )
    )
    (if (< (length LPint) 2)
        (progn
            (alert
                "The polylines do not intersect in at least two points."
            )
            (exit)
        )
    )
)
;;; Returns a list of boundary points of the area to be hatched
(defun calcolo_contorno_tratteggio (/ x P_trat_esist P_trat_prog Dp- Dp+ L dist )
    ;First polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3 p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3 p+))   
    (if inv_p1
        (setq
            L (vlax-get-property (vlax-ename->vla-object e3) 'length)
            Dp- (- L Dp-)
            Dp+ (- L Dp+)
        )
    )
    (mapcar
        '(lambda (x)
             (setq dist (vlax-curve-getDistAtPoint e3 x))
             (if inv_p1 (setq dist (- L dist)))
             (if (and                                                               
                     (> dist 1e-6)       
                     (> dist Dp-)
                     (< dist Dp+)                             
                 )   
                 (setq P_trat_esist (cons x P_trat_esist))
      )
         )
  ListaV
    )
    (setq P_trat_esist (reverse P_trat_esist))
    ;Second polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3p p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3p p+))   
    (if inv_p2
        (setq
            L (vlax-get-property (vlax-ename->vla-object e3p) 'length)
            Dp- (- L Dp-)
            Dp+ (- L Dp+)
        )
    )
    (mapcar
        '(lambda (x)
             (setq dist (vlax-curve-getDistAtPoint e3p x))
             (if inv_p2 (setq dist (- L dist)))           
             (if (and                           
                     (> dist 1e-6)
                     (> dist Dp-)
                     (< dist Dp+)
                 )   
                 (setq P_trat_prog (cons x P_trat_prog))
      )
         )
         ListaVp
    )
    (setq P_trat_prog (reverse P_trat_prog))
    ;Hatch boundary
    (setq contorno_trat (append (cons p- P_trat_esist) (list p+)))   
    (repeat (setq n (length P_trat_prog))
 (setq contorno_trat (append contorno_trat (list (nth (setq n (1- n)) P_trat_prog))))
    )
)
;;;ListClockwise-p
(defun ListClockwise-p (lst / z vlst)
    (vl-catch-all-apply
        'minusp
        (list
            (if
                (not
                    (equal 0.0
                           (setq z
                                    (apply '+
                                           (mapcar
                                               (function
                                                   (lambda (u v)
                                                       (- (* (car u) (cadr v))
                                                          (* (car v) (cadr u))
                                                       )
                                                   )
                                               )
                                               (setq vlst
                                                        (mapcar
                                                            (function
                                                                (lambda (a b)
                                                                    (mapcar '- b a)
                                                                )
                                                            )
                                                            lst
                                                            (cdr (reverse
                                                                     (cons (car lst)
                                                                           (reverse lst)
                                                                     )
                                                                 )
                                                            )
                                                        )
                                               )
                                               (cdr (reverse (cons (car vlst)
                                                                   (reverse vlst)
                                                             )
                                                    )
                                               )
                                           )
                                    )
                           )
                           1e-6
                    )
                )
                   z
                   (progn
                       (prompt
                           "\n\nChecked vectors are colinear - unable to determine clockwise-p of list"
                       )
                       nil
                   )
            )
        )
    )
)
;;;Return the hatch color
(defun calcolo_tipo_area nil
    (if (ListClockwise-p contorno_trat)
        (setq col 4)
        (setq col 2)
    )
)
;;;Hatch
(defun disegno_hatch (/ i hatch_def)
    (setq contorno_trat (cons (last contorno_trat) contorno_trat))
    (setq hatch_def (list
                        '(0 . "HATCH")
                        '(100 . "AcDbEntity")
                        '(67 . 0)
                        '(410 . "Model")
                        (cons 62 col)
                        '(100 . "AcDbHatch")
                        '(10 0.0 0.0 0.0)
                        '(210 0.0 0.0 1.0)
                        '(2 . "SOLID")
                        '(70 . 1)
                        '(71 . 0)
                        '(91 . 1)
                        '(92 . 1)
                        (cons 93 (1- (length contorno_trat)))
                    )
    )
    (repeat (setq i (1- (length contorno_trat)))
        (setq hatch_def
                 (append
                     hatch_def
                     (list '(72 . 1))
                     (list (cons 10 (nth i contorno_trat)))
                     (list (cons 11 (nth (setq i (1- i)) contorno_trat)))
                 )
        )
    )
    (setq hatch_def
             (append
                 hatch_def
                 (list '(97 . 0))
                 (list '(75 . 0))
                 (list '(76 . 1))
                 (list '(98 . 1))
                 (list '(10 0.0 0.0 0.0))
                 (list '(470 . "LINEAR"))
             )
    )
    (entmake hatch_def)
    (command "_.draworder" (entlast) "" "_b")
)

 
 
« Last Edit: September 16, 2013, 01:55:56 PM by GP »

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #14 on: February 17, 2014, 05:37:15 AM »
GP, replace this my mistake in your code...

Change this :
Code: [Select]
...
                                               (setq vlst
                                                        (mapcar
                                                            (function
                                                                (lambda (a b)
                                                                    (mapcar '- b a)
                                                                )
                                                            )
                                                            lst
                                                            (cdr (reverse
                                                                     (cons (car lst)
                                                                           (reverse lst)
                                                                     )
                                                                 )
                                                            )
                                                        )
                                               )
...

To this :

Code: [Select]
...
                                               (setq vlst
                                                        (mapcar
                                                            (function
                                                                (lambda (a b)
                                                                    (mapcar '- b a)
                                                                )
                                                            )
                                                            (mapcar
                                                                (function
                                                                    (lambda (x)
                                                                        (car lst)
                                                                    )
                                                                ) lst
                                                            )
                                                            (cdr (reverse
                                                                     (cons (car lst)
                                                                           (reverse lst)
                                                                     )
                                                                 )
                                                            )
                                                        )
                                               )
...

Sorry for late reply and for my mistake...
Sincerely, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube