Topic: dietpl.lsp - solving endless while loop

[ribarm]

I have trouble with this routine I coded recently... This question was asked before, but I and others didn't wanted to answer as question was delicate and by solving result should be very similar to original source entity in question - LWPOLYLINE with / without arced segments...
In attachment is my DWG I quickly created with one of my PLINETOOLS archive and desired solution for this problem is already there., i.e. I created green lwpolyline from white on right side and my goal is that now I am trying to create white from green on the left side... Green lwpolyline has many unnecessary vertices, and so I coded for making diet polyline with only those vertices that are in white lwpolyline... You'll see all in DWG when you download it...
Sadly my code is going in endless (while) loops from 2 sub functions contained in routine named (group_*)...
Can someone try to fix and find where is the problem as I think that those subs are needed for this routine...

Code: [Select]

(defun c:dietpl ( / vertlst bulglst collinear-p group_collinear_pts group_fuzz_pts mid acos tang clockwise-p s fuzz lw ptlst blst assoclst gg g p1 p2 p3 mp1 mp2 c r d ang b nlw lwx )

  (defun vertlst ( lw )
    (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))
  )

  (defun bulglst ( lw )
    (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) (entget lw)))
  )

  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )

  (defun group_collinear_pts ( ptlst / a b c g gg )
    (while ptlst
      (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
      (while (and c (collinear-p a b c))
        (if (not (vl-position a g))
          (setq g (cons a g))
        )
        (if (not (vl-position b g))
          (setq g (cons b g))
        )
        (if (not (vl-position c g))
          (setq g (cons c g))
        )
        (setq ptlst (cdr ptlst))
      )
      (setq ptlst (cdr ptlst))
      (setq gg (cons (reverse g) gg))
      (setq g nil)
    )
    (reverse gg)
  )

  (defun group_fuzz_pts ( ptlst fuzz / a b g gg )
    (while ptlst
      (setq a (car ptlst) b (cadr ptlst))
      (while (and b (< (distance a b) fuzz))
        (if (not (vl-position a g))
          (setq g (cons a g))
        )
        (if (not (vl-position b g))
          (setq g (cons b g))
        )
        (setq ptlst (cdr ptlst))
      )
      (setq ptlst (cdr ptlst))
      (setq gg (cons (reverse g) gg))
      (setq g nil)
    )
    (reverse gg)
  )

  (defun mid ( p1 p2 )
    (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
  )

  (defun acos ( x )
    (cond
      ( (equal x 1.0 1e-8) 0.0 )
      ( (equal x -1.0 1e-8) pi )
      ( (and
          (>= x 0.0)
          (equal x 0.0 1e-8)
        )
        (/ pi 2.0)
      )
      ( (and
          (<= x 0.0)
          (equal x -0.0 1e-8)
        )
        (* 3.0 (/ pi 2.0))
      )
      ( t
        (atan (sqrt (- 1.0 (* x x))) x)
      )
    )
  )

  (defun tang ( a )
    (/ (sin a) (cos a))
  )

  (defun clockwise-p ( p1 p p2 )
    (minusp (- (* (car (mapcar (function -) p1 p)) (cadr (mapcar (function -) p2 p))) (* (cadr (mapcar (function -) p1 p)) (car (mapcar (function -) p2 p)))))
  )

  (prompt "\nPick LWPOLYLINE to make it with diet...")
  (if
    (and
      (setq s (ssget "_+.:E:S" (list (cons 0 "LWPOLYLINE"))))
      (not (initget 7))
      (setq fuzz (getdist "\nPick or specify fuzz distance : "))
    )
    (progn
      (setq lw (ssname s 0))
      (setq ptlst (vertlst lw))
      (setq blst (bulglst lw))
      (setq assoclst (mapcar (function (lambda ( p b ) (cons p b))) ptlst blst))
      (setq gg (group_collinear_pts ptlst))
      (foreach g gg
        (setq g (cdr g) g (reverse (cdr (reverse g))))
        (foreach p g
          (setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
        )
      )
      (setq gg (group_fuzz_pts ptlst fuzz))
      (foreach g gg
        (setq p1 (car g) p2 (cadr g) p3 (last g))
        (setq mp1 (mid p1 p2) mp2 (mid p2 p3))
        (setq c (inters mp1 (polar mp1 (+ (angle p1 p2) (* 0.5 pi)) 1.0) mp2 (polar mp2 (+ (angle p2 p3) (* 0.5 pi)) 1.0) nil))
        (setq r (distance c p1))
        (setq d (distance (mid p1 p3) c))
        (setq ang (* 2.0 (acos (/ d r))))
        (setq b (tang (/ ang 4.0)))
        (if (clockwise-p p1 c p3)
          (setq b (- b))
        )
        (setq assoclst (subst (cons (car g) b) (vl-some (function (lambda ( x ) (if (equal (car x) (car g) 1e-6) x))) assoclst) assoclst))
        (setq g (cdr g) g (reverse (cdr (reverse g))))
        (foreach p g
          (setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
        )
      )
      (setq nlw
        (entmakex
          (append
            (list
              (cons 0 "LWPOLYLINE")
              (cons 100 "AcDbEntity")
              (cons 100 "AcDbPolyline")
              (cons 90 (length assoclst))
              (assoc 70 (setq lwx (entget lw)))
              (assoc 38 lwx)
            )
            (apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (mapcar (function car) assoclst) (mapcar (function cdr) assoclst)))
            (list (assoc 210 lwx))
          )
        )
      )
    )
  )
  (princ)
)

Regards, M.R.

[BIGAL]

Hi marko had a bit of a play and the problem is in this line (setq gg (group_collinear_pts ptlst)) so the function group_collinear never finishes, I tried like (princ (setq x (1+ x)) in the defun and it just went off screen so not sure what number it got to tried adding (if (= x 150)(exit)) to crash it out rather than endless loop. I think its to do with (while ptlst is not ever ending may need a say a check ptlst not sure what it should be then set another variable that is used in (while (= chk "no") etc.

The only way I would find out what is happening is to run the code below the while but knowing how many times I need to run it using copy paste .

Oh yeah may be the problem here (collinear-p a b c)) read as XYZ values but ptlst is only XY there is no Z. You have check X check Y check Z but I dont know what Z is ? NIL 0.0, Just crashed it again, forced to use taskmanager.

[ribarm]

Problem sucessfuly solved...
Here is the code...

Code - Auto/Visual Lisp: [Select]

1. (defun c:dietlws ( / *error* unique vertlst bulglst collinear-p group_collinear_pts group_fuzz_pts clockwise-p cmd s so fuzz in lw ptlst blst assoclst gg g n p1 p2 p3 b lwx )
2.  
3.   (defun *error* ( m )
4.     (while (= 8 (logand 8 (getvar (quote undoctl))))
5.       (if command-s
6.         (command-s "_.UNDO" "_E")
7.         (vl-cmdf "_.UNDO" "_E")
8.       )
9.     )
10.     (if cmd
11.       (setvar (quote cmdecho) cmd)
12.     )
13.     (if m
14.       (prompt m)
15.     )
16.     (princ)
17.   )
18.  
19.   (defun unique ( lst )
20.     (if lst
21.       (cons (car lst)
22.         (unique
23.           (vl-remove-if (function (lambda ( x ) (equal x (car lst) 1e-3)))
24.             (cdr lst)
25.           )
26.         )
27.       )
28.     )
29.   )
30.  
31.   (defun vertlst ( lwx )
32.     (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx))
33.   )
34.  
35.   (defun bulglst ( lwx )
36.     (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx))
37.   )
38.  
39.   (defun collinear-p ( p1 p p2 )
40.     (and
41.       (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
42.       (equal (angle p1 p2) (angle p1 p) 1e-6)
43.       (equal (angle p1 p2) (angle p p2) 1e-6)
44.     )
45.   )
46.  
47.   (defun group_collinear_pts ( ptlst / a b c g gg )
48.     (while ptlst
49.       (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
50.       (while (and c (collinear-p a b c))
51.         (if (not (vl-position a g))
52.           (setq g (cons a g))
53.         )
54.         (if (not (vl-position b g))
55.           (setq g (cons b g))
56.         )
57.         (if (not (vl-position c g))
58.           (setq g (cons c g))
59.         )
60.         (setq ptlst (cdr ptlst))
61.         (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
62.       )
63.       (setq ptlst (cdr ptlst))
64.       (if g
65.         (setq gg (cons (reverse g) gg))
66.       )
67.       (setq g nil)
68.     )
69.     (reverse gg)
70.   )
71.  
72.   (defun group_fuzz_pts ( ptlst fuzz / a b c f ff g gg )
73.     (while ptlst
74.       (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
75.       (if (and a b c)
76.         (setq ff nil)
77.       )
78.       (while (and (not ff) c (and b (< (distance a b) fuzz)) (and c (< (distance b c) fuzz)))
79.         (setq f (clockwise-p a b c))
80.         (if (not (vl-position a g))
81.           (setq g (cons a g))
82.         )
83.         (if (not (vl-position b g))
84.           (setq g (cons b g))
85.         )
86.         (if (not (vl-position c g))
87.           (setq g (cons c g))
88.         )
89.         (setq ptlst (cdr ptlst))
90.         (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
91.         (if (and c (/= f (clockwise-p a b c)))
92.           (setq ff t)
93.           (setq ff nil)
94.         )
95.       )
96.       (setq ptlst (cdr ptlst))
97.       (if g
98.         (setq gg (cons (reverse g) gg))
99.       )
100.       (setq g nil)
101.     )
102.     (reverse gg)
103.   )
104.  
105.   (defun clockwise-p ( p1 p p2 )
106.     (minusp (- (* (car (mapcar (function -) p1 p)) (cadr (mapcar (function -) p2 p))) (* (cadr (mapcar (function -) p1 p)) (car (mapcar (function -) p2 p)))))
107.   )
108.  
109.   (setq cmd (getvar (quote cmdecho)))
110.   (setvar (quote cmdecho) 0)
111.   (while (= 8 (logand 8 (getvar (quote undoctl))))
112.     (if command-s
113.       (command-s "_.UNDO" "_E")
114.       (vl-cmdf "_.UNDO" "_E")
115.     )
116.   )
117.   (if command-s
118.     (command-s "_.UNDO" "_BE")
119.     (vl-cmdf "_.UNDO" "_BE")
120.   )
121.   (prompt "\nSelect LWPOLYLINE(S) to make it/them with diet...")
122.   (if (setq s (ssget (list (cons 0 "LWPOLYLINE"))))
123.     (repeat (setq in (sslength s))
124.       (setq lwx (entget (setq lw (ssname s (setq in (1- in))))))
125.       (setq ptlst (vertlst lwx))
126.       (setq fuzz (- (* 2.0 (car (setq so (vl-sort (unique (mapcar (function (lambda ( a b ) (distance a b))) ptlst (cdr ptlst))) (function <))))) 1e-3))
127.       (if (vl-some (function (lambda ( x ) (> x fuzz))) so)
128.         (setq fuzz (+ (last so) 1e-3))
129.       )
130.       (setq blst (bulglst lwx))
131.       (setq assoclst (mapcar (function (lambda ( p b ) (cons p b))) ptlst blst))
132.       (setq gg (group_collinear_pts ptlst))
133.       (foreach g gg
134.         (setq g (cdr g) g (reverse (cdr (reverse g))))
135.         (foreach p g
136.           (setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
137.         )
138.       )
139.       (setq gg (group_fuzz_pts (mapcar (function car) assoclst) fuzz))
140.       (foreach g gg
141.         (setq n (length g))
142.         (setq p1 (car g) p2 (nth (if (> n 3) (fix (/ n 2.0)) 1) g) p3 (last g))
143.         (if command-s
144.           (command-s "_.pline" "_non" p1 "_a" "_s" "_non" p2 "_non" p3 "")
145.           (vl-cmdf "_.pline" "_non" p1 "_a" "_s" "_non" p2 "_non" p3 "")
146.         )
147.         (setq b (cdr (assoc 42 (entget (entlast)))))
148.         (entdel (entlast))
149.         (setq assoclst (subst (cons (car g) b) (vl-some (function (lambda ( x ) (if (equal (car x) (car g) 1e-6) x))) assoclst) assoclst))
150.         (setq g (cdr g) g (reverse (cdr (reverse g))))
151.         (foreach p g
152.           (setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
153.         )
154.       )
155.       (if (and (= 1 (logand 1 (cdr (assoc 70 lwx)))) (< (distance (caar assoclst) (car (last assoclst))) fuzz))
156.         (setq assoclst (reverse (cdr (reverse assoclst))))
157.       )
158.       (entmake
159.         (append
160.           (list
161.             (cons 0 "LWPOLYLINE")
162.             (cons 100 "AcDbEntity")
163.             (cons 100 "AcDbPolyline")
164.             (cons 90 (length assoclst))
165.             (assoc 70 lwx)
166.             (assoc 38 lwx)
167.           )
168.           (apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (mapcar (function car) assoclst) (mapcar (function cdr) assoclst)))
169.           (list (assoc 210 lwx))
170.         )
171.       )
172.       (setq gg nil assoclst nil)
173.     )
174.   )
175.   (*error* nil)
176. )
177.  

And here is slightly different code... Maybe it's better...

Code - Auto/Visual Lisp: [Select]

1. (defun c:dietlws ( / *error* unique vertlst bulglst collinear-p group_collinear_pts group_fuzz_pts clockwise-p cmd s so fuzz in lw ptlst blst lst assoclst gg g n p1 p2 p3 b lwx )
2.  
3.   (defun *error* ( m )
4.     (while (= 8 (logand 8 (getvar (quote undoctl))))
5.       (if command-s
6.         (command-s "_.UNDO" "_E")
7.         (vl-cmdf "_.UNDO" "_E")
8.       )
9.     )
10.     (if cmd
11.       (setvar (quote cmdecho) cmd)
12.     )
13.     (if m
14.       (prompt m)
15.     )
16.     (princ)
17.   )
18.  
19.   (defun unique ( lst )
20.     (if lst
21.       (cons (car lst)
22.         (unique
23.           (vl-remove-if (function (lambda ( x ) (equal x (car lst) 1e-3)))
24.             (cdr lst)
25.           )
26.         )
27.       )
28.     )
29.   )
30.  
31.   (defun vertlst ( lwx )
32.     (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx))
33.   )
34.  
35.   (defun bulglst ( lwx )
36.     (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx))
37.   )
38.  
39.   (defun collinear-p ( p1 p p2 )
40.     (and
41.       (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
42.       (equal (angle p1 p2) (angle p1 p) 1e-6)
43.       (equal (angle p1 p2) (angle p p2) 1e-6)
44.     )
45.   )
46.  
47.   (defun group_collinear_pts ( ptlst / a b c g gg )
48.     (while ptlst
49.       (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
50.       (while (and c (collinear-p a b c))
51.         (if (not (vl-position a g))
52.           (setq g (cons a g))
53.         )
54.         (if (not (vl-position b g))
55.           (setq g (cons b g))
56.         )
57.         (if (not (vl-position c g))
58.           (setq g (cons c g))
59.         )
60.         (setq ptlst (cdr ptlst))
61.         (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
62.       )
63.       (setq ptlst (cdr ptlst))
64.       (if g
65.         (setq gg (cons (reverse g) gg))
66.       )
67.       (setq g nil)
68.     )
69.     (reverse gg)
70.   )
71.  
72.   (defun group_fuzz_pts ( ptlst fuzz / a b c f ff g gg )
73.     (while ptlst
74.       (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
75.       (if (and a b c)
76.         (setq ff nil)
77.       )
78.       (while (and (not ff) c (and b (< (distance a b) fuzz)) (and c (< (distance b c) fuzz)) (and b (>= (distance a b) (/ fuzz 1.9))) (and c (>= (distance b c) (/ fuzz 1.9))))
79.         (setq f (clockwise-p a b c))
80.         (if (not (vl-position a g))
81.           (setq g (cons a g))
82.         )
83.         (if (not (vl-position b g))
84.           (setq g (cons b g))
85.         )
86.         (if (not (vl-position c g))
87.           (setq g (cons c g))
88.         )
89.         (setq ptlst (cdr ptlst))
90.         (setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
91.         (if (and c (/= f (clockwise-p a b c)))
92.           (setq ff t)
93.           (setq ff nil)
94.         )
95.       )
96.       (setq ptlst (cdr ptlst))
97.       (if g
98.         (setq gg (cons (reverse g) gg))
99.       )
100.       (setq g nil)
101.     )
102.     (reverse gg)
103.   )
104.  
105.   (defun clockwise-p ( p1 p p2 )
106.     (minusp (- (* (car (mapcar (function -) p1 p)) (cadr (mapcar (function -) p2 p))) (* (cadr (mapcar (function -) p1 p)) (car (mapcar (function -) p2 p)))))
107.   )
108.  
109.   (setq cmd (getvar (quote cmdecho)))
110.   (setvar (quote cmdecho) 0)
111.   (while (= 8 (logand 8 (getvar (quote undoctl))))
112.     (if command-s
113.       (command-s "_.UNDO" "_E")
114.       (vl-cmdf "_.UNDO" "_E")
115.     )
116.   )
117.   (if command-s
118.     (command-s "_.UNDO" "_BE")
119.     (vl-cmdf "_.UNDO" "_BE")
120.   )
121.   (prompt "\nSelect LWPOLYLINE(S) to make it/them with diet...")
122.   (if (setq s (ssget (list (cons 0 "LWPOLYLINE"))))
123.     (repeat (setq in (sslength s))
124.       (setq lwx (entget (setq lw (ssname s (setq in (1- in))))))
125.       (setq ptlst (vertlst lwx))
126.       (setq blst (bulglst lwx))
127.       (setq assoclst (mapcar (function (lambda ( p b ) (cons p b))) ptlst blst))
128.       (setq gg (group_collinear_pts ptlst))
129.       (foreach g gg
130.         (setq g (cdr g) g (reverse (cdr (reverse g))))
131.         (foreach p g
132.           (setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
133.         )
134.       )
135.       (setq lst (mapcar (function car) assoclst))
136.       (while (not (equal (last (last gg)) (car lst) 1e-6))
137.         (if (and (cadr lst) (caddr lst))
138.           (setq fuzz (* 1.95 (distance (cadr lst) (caddr lst))))
139.         )
140.         (setq gg (group_fuzz_pts lst fuzz))
141.         (foreach g gg
142.           (setq n (length g))
143.           (if (> n 3)
144.             (progn
145.               (setq p1 (car g) p2 (nth (fix (/ n 2.0)) g) p3 (last g))
146.               (if command-s
147.                 (command-s "_.pline" "_non" p1 "_a" "_s" "_non" p2 "_non" p3 "")
148.                 (vl-cmdf "_.pline" "_non" p1 "_a" "_s" "_non" p2 "_non" p3 "")
149.               )
150.               (setq b (cdr (assoc 42 (entget (entlast)))))
151.               (entdel (entlast))
152.               (setq assoclst (subst (cons (car g) b) (vl-some (function (lambda ( x ) (if (equal (car x) (car g) 1e-6) x))) assoclst) assoclst))
153.               (setq g (cdr g) g (reverse (cdr (reverse g))))
154.               (foreach p g
155.                 (setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
156.                 (setq lst (vl-remove-if (function (lambda ( x ) (equal p x 1e-6))) lst))
157.               )
158.             )
159.           )
160.         )
161.         (setq lst (cdr lst))
162.       )
163.       (if (and (= 1 (logand 1 (cdr (assoc 70 lwx)))) (collinear-p (caadr (reverse assoclst)) (caar (reverse assoclst)) (caar assoclst)))
164.         (setq assoclst (reverse (cdr (reverse assoclst))))
165.       )
166.       (entmake
167.         (append
168.           (list
169.             (cons 0 "LWPOLYLINE")
170.             (cons 100 "AcDbEntity")
171.             (cons 100 "AcDbPolyline")
172.             (cons 90 (length assoclst))
173.             (assoc 70 lwx)
174.             (assoc 38 lwx)
175.           )
176.           (apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (mapcar (function car) assoclst) (mapcar (function cdr) assoclst)))
177.           (list (assoc 210 lwx))
178.         )
179.       )
180.       (setq gg nil assoclst nil lst nil)
181.     )
182.   )
183.   (*error* nil)
184. )
185.  

HTH.
M.R.

[MSTG007]

Nice Job. Very Powerful.

[dgpuertas]

Thanks,

solve this issue

https://www.theswamp.org/index.php?topic=58703.msg617005