Author Topic: vlax-curve-getfurthestpointfrom  (Read 28650 times)

0 Members and 1 Guest are viewing this topic.

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: vlax-curve-getfurthestpointfrom
« Reply #30 on: July 13, 2012, 07:24:50 PM »
Some alternatives for the Circle solution:

Code - Auto/Visual Lisp: [Select]
  1. (   (= "CIRCLE" etype)
  2.     (if (not (equal point (setq cen (cdr (assoc 10 elst)))))
  3.         (progn
  4.             (setq d (/ (cdr (assoc 40 elst)) (distance point cen)))
  5.             (mapcar (function (lambda ( a b ) (+ a (* b d)))) cen (mapcar '- cen point))
  6.         )
  7.     )
  8. )

Code - Auto/Visual Lisp: [Select]
  1. (   (= "CIRCLE" etype)
  2.     (if (not (equal point (setq cen (cdr (assoc 10 elst)))))
  3.         (polar cen (angle point cen) (cdr (assoc 40 elst)))
  4.     )
  5. )

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #31 on: July 14, 2012, 01:16:56 AM »
Based on Zoltan's code, here is mine version - my recursion between 2 furthest points... And look for CIRCLE and ELLIPSE solutions (main routine should calc. result) - only exception is when point is center, then I changed little center point, just slightly translation, so that main routine can calc. result...

Code - Auto/Visual Lisp: [Select]
  1. (Defun MR-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag)
  2. (SetQ samples 200
  3.      tolerance 1e-8
  4. )
  5.  
  6. (Defun FurthestParameter (SP EP / seg params par furthest )
  7. (SetQ params (List SP))
  8. (SetQ seg 0.0)
  9.  
  10. (Defun IsFurther ( A B P )
  11.  (>= (Distance A P) (Distance B P))
  12. )
  13.  
  14. (Repeat (1- samples)
  15.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  16. )
  17.  
  18. (SetQ furthest (Car (SetQ par
  19.                 (Vl-Sort-I
  20.                  params
  21.                  (Function
  22.                   (Lambda (a b)
  23.                    (IsFurther
  24.                     (VLAX-Curve-GetPointAtParam CURVE a)
  25.                     (VLAX-Curve-GetPointAtParam CURVE b)
  26.                     POINT
  27.                    )
  28.                   )
  29.                  )
  30.                 ))
  31.                )
  32. )
  33.  
  34. (If (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance)
  35.  (FurthestParameter
  36.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  37.    (Nth furthest params)
  38.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  39.     (Nth (Cadr par) params)
  40.     (Nth (Caddr par) params)
  41.    )
  42.   )
  43.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  44.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  45.     (Nth (Cadr par) params)
  46.     (Nth (Caddr par) params)
  47.    )
  48.    (Nth furthest params)
  49.   )
  50.  )
  51.  (Nth furthest params)
  52. )
  53. )
  54.  
  55.   CURVE
  56.   (FurthestParameter
  57.   )
  58.  )
  59.  
  60. )
  61.  
  62. (defun vlax-curve-getfurthestpointfrom ( CURVE POINT / elst etype 2dtype lstn )
  63.  
  64. (Defun IsFurther ( A B P )
  65.  (>= (Distance A P) (Distance B P))
  66. )
  67.  
  68. (defun _polyvertices ( lst )
  69.   (_vertices2 (entnext (cdr (assoc -1 lst))))
  70. )
  71.  
  72. (defun _vertices2 ( e )
  73.   (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
  74.     (progn
  75.       (setq lstn (cons (assoc 10 (entget e)) lstn))
  76.       (setq lstn (cons (assoc 42 (entget e)) lstn))
  77.       (_vertices2 (entnext e))
  78.     )
  79.   )
  80.   (reverse lstn)
  81. )
  82.  
  83. (defun member-fuzz (expr lst fuzz)
  84.   (while (and lst (not (equal (car lst) expr fuzz)))
  85.     (setq lst (cdr lst))
  86.   )
  87.   lst
  88. )
  89.  
  90. (defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  91.   (setq enpar (vlax-curve-getendparam ent))
  92.   (setq n -1)
  93.   (repeat (fix enpar)
  94.     (setq n (1+ n))
  95.     (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
  96.     (setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
  97.     (if (/= bulge 0.0)
  98.       (progn
  99.         (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
  100.         (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
  101.         (setq cenlst (cons cen cenlst))
  102.       )
  103.     )
  104.   )
  105.   (reverse cenlst)
  106. )
  107.  
  108. (SetQ elst (entget CURVE))
  109. (SetQ etype (Cdr (Assoc 0 elst)))
  110.  
  111. ((= "XLINE" etype)
  112.  nil
  113. )
  114. ((= "RAY" etype)
  115.  nil
  116. )
  117. ((= "LINE" etype)
  118.  (If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
  119.   (Cdr (Assoc 10 elst))
  120.   (Cdr (Assoc 11 elst))
  121.  )
  122. )
  123. ((And
  124.   (= "ARC" etype)
  125.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  126.  )
  127.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  128. )
  129. ((And
  130.   (= "CIRCLE" etype)
  131.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  132.  )
  133.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  134. )
  135. ((And
  136.   (= "ELLIPSE" etype)
  137.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  138.  )
  139.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  140. )
  141. ((And
  142.   (= "LWPOLYLINE" etype)
  143.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  144.  )
  145.  (Car
  146.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  147.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  148.   )
  149.  )
  150. )
  151. ((And
  152.   (= "LWPOLYLINE" etype)
  153.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  154.   (member-fuzz POINT (_plcents CURVE) 1e-8)
  155.  )
  156.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  157. )
  158. ((And
  159.   (= "POLYLINE" etype)
  160.   (SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
  161.   (SetQ elst (_polyvertices elst))
  162.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  163.   (If (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents CURVE) 1e-8))
  164.  )
  165.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  166. )
  167. ((And
  168.   (= "POLYLINE" etype)
  169.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  170.  )
  171.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  172. )
  173. ((And
  174.   (= "POLYLINE" etype)
  175.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  176.  )
  177.  (Car
  178.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  179.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  180.   )
  181.  )
  182. )
  183. (T
  184.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  185. )
  186. )
  187. )
  188.  

P.S. I like your way of dealing with tolerances and enlarging list of parameters with segmentation... BTW I took 200 samples, tolerance 1e-8...

M.R.
« Last Edit: July 16, 2012, 12:30:45 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #32 on: July 15, 2012, 05:41:12 AM »
The more time passes, I figure that both logics and mine and Zoltans have their benefits... So I combined them into one single function (vlax-curve-getfurthestpointfrom) - for now I couldn't think of better name as it describes what should real missing VLisp function do...

Code - Auto/Visual Lisp: [Select]
  1. (Defun ZF-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag)
  2. (SetQ samples 200
  3.      tolerance 1e-8
  4. )
  5.  
  6. (Defun FurthestParameter (SP EP / seg params par furthest )
  7. (SetQ params (List SP))
  8. (SetQ seg 0.0)
  9.  
  10. (Defun IsFurther ( A B P )
  11.  (>= (Distance A P) (Distance B P))
  12. )
  13.  
  14. (Repeat (1- samples)
  15.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  16. )
  17.  
  18. (SetQ furthest (Car (SetQ par
  19.                 (Vl-Sort-I
  20.                  params
  21.                  (Function
  22.                   (Lambda (a b)
  23.                    (IsFurther
  24.                     (VLAX-Curve-GetPointAtParam CURVE a)
  25.                     (VLAX-Curve-GetPointAtParam CURVE b)
  26.                     POINT
  27.                    )
  28.                   )
  29.                  )
  30.                 ))
  31.                )
  32. )
  33.  
  34. (If (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance)
  35.  (FurthestParameter
  36.   (If (< (Nth (Cadr par) params) (Nth (Caddr par) params))
  37.    (Nth (Cadr par) params)
  38.    (Nth (Caddr par) params)
  39.   )
  40.   (If (< (Nth (Cadr par) params) (Nth (Caddr par) params))
  41.    (Nth (Caddr par) params)
  42.    (Nth (Cadr par) params)
  43.   )
  44.  )
  45.  (Nth furthest params)
  46. )
  47. )
  48.  
  49.   CURVE
  50.   (FurthestParameter
  51.   )
  52.  )
  53.  
  54. )
  55.  
  56.  
  57. (Defun MR-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag)
  58. (SetQ samples 200
  59.      tolerance 1e-8
  60. )
  61.  
  62. (Defun FurthestParameter (SP EP / seg params par furthest )
  63. (SetQ params (List SP))
  64. (SetQ seg 0.0)
  65.  
  66. (Defun IsFurther ( A B P )
  67.  (>= (Distance A P) (Distance B P))
  68. )
  69.  
  70. (Repeat (1- samples)
  71.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  72. )
  73.  
  74. (SetQ furthest (Car (SetQ par
  75.                 (Vl-Sort-I
  76.                  params
  77.                  (Function
  78.                   (Lambda (a b)
  79.                    (IsFurther
  80.                     (VLAX-Curve-GetPointAtParam CURVE a)
  81.                     (VLAX-Curve-GetPointAtParam CURVE b)
  82.                     POINT
  83.                    )
  84.                   )
  85.                  )
  86.                 ))
  87.                )
  88. )
  89.  
  90. (If (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance)
  91.  (FurthestParameter
  92.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  93.    (Nth furthest params)
  94.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  95.     (Nth (Cadr par) params)
  96.     (Nth (Caddr par) params)
  97.    )
  98.   )
  99.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  100.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  101.     (Nth (Cadr par) params)
  102.     (Nth (Caddr par) params)
  103.    )
  104.    (Nth furthest params)
  105.   )
  106.  )
  107.  (Nth furthest params)
  108. )
  109. )
  110.  
  111.   CURVE
  112.   (FurthestParameter
  113.   )
  114.  )
  115.  
  116. )
  117.  
  118. (defun vlax-curve-getfurthestpointfrom ( CURVE POINT / elst etype 2dtype lstn )
  119.  
  120. (Defun IsFurther ( A B P )
  121.  (>= (Distance A P) (Distance B P))
  122. )
  123.  
  124. (defun _polyvertices ( lst )
  125.   (_vertices2 (entnext (cdr (assoc -1 lst))))
  126. )
  127.  
  128. (defun _vertices2 ( e )
  129.   (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
  130.     (progn
  131.       (setq lstn (cons (assoc 10 (entget e)) lstn))
  132.       (setq lstn (cons (assoc 42 (entget e)) lstn))
  133.       (_vertices2 (entnext e))
  134.     )
  135.   )
  136.   (reverse lstn)
  137. )
  138.  
  139. (defun member-fuzz (expr lst fuzz)
  140.   (while (and lst (not (equal (car lst) expr fuzz)))
  141.     (setq lst (cdr lst))
  142.   )
  143.   lst
  144. )
  145.  
  146. (defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  147.   (setq enpar (vlax-curve-getendparam ent))
  148.   (setq n -1)
  149.   (repeat (fix enpar)
  150.     (setq n (1+ n))
  151.     (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
  152.     (setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
  153.     (if (/= bulge 0.0)
  154.       (progn
  155.         (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
  156.         (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
  157.         (setq cenlst (cons cen cenlst))
  158.       )
  159.     )
  160.   )
  161.   (reverse cenlst)
  162. )
  163.  
  164. (SetQ elst (entget CURVE))
  165. (SetQ etype (Cdr (Assoc 0 elst)))
  166.  
  167. ((= "XLINE" etype)
  168.  nil
  169. )
  170. ((= "RAY" etype)
  171.  nil
  172. )
  173. ((= "LINE" etype)
  174.  (If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
  175.   (Cdr (Assoc 10 elst))
  176.   (Cdr (Assoc 11 elst))
  177.  )
  178. )
  179. ((And
  180.   (= "ARC" etype)
  181.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  182.  )
  183.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  184. )
  185. ((And
  186.   (= "CIRCLE" etype)
  187.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  188.  )
  189.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  190. )
  191. ((And
  192.   (= "ELLIPSE" etype)
  193.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  194.  )
  195.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  196. )
  197. ((And
  198.   (= "LWPOLYLINE" etype)
  199.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  200.  )
  201.  (Car
  202.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  203.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  204.   )
  205.  )
  206. )
  207. ((And
  208.   (= "LWPOLYLINE" etype)
  209.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  210.   (member-fuzz POINT (_plcents CURVE) 1e-8)
  211.  )
  212.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  213. )
  214. ((And
  215.   (= "POLYLINE" etype)
  216.   (SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
  217.   (SetQ elst (_polyvertices elst))
  218.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  219.   (If (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents CURVE) 1e-8))
  220.  )
  221.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  222. )
  223. ((And
  224.   (= "POLYLINE" etype)
  225.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  226.  )
  227.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  228. )
  229. ((And
  230.   (= "POLYLINE" etype)
  231.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  232.  )
  233.  (Car
  234.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  235.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  236.   )
  237.  )
  238. )
  239. ((= "SPLINE" etype)
  240.  (ZF-Curve-GetFurthestPointFrom CURVE POINT)
  241. )
  242. (T
  243.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  244. )
  245. )
  246. )
  247.  

Regards, once again M.R.
« Last Edit: July 16, 2012, 12:30:22 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #33 on: July 15, 2012, 10:00:46 AM »
Code updated to cover all possible combinations of CURVE objects and POINT argument...

And not to forget - giving accreditation to Gile for his subfunction (member-fuzz) as it was used in above posted code and it was taken from Giles website... Link is list manipulations - list subfunctions :

Listes

M.R.

Also, many thanks to Lee Mac for participation and his suggestions in this thread... My final code would never been created without his useful help... So all kudos to Lee too...

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #34 on: July 15, 2012, 05:22:43 PM »
No use... Still my subfunction is more reliable in finding approx correct solution...

So my final conclusion is updated code :
http://www.theswamp.org/index.php?topic=42246.msg474040#msg474040

or attached *.lsp

M.R.
« Last Edit: July 16, 2012, 12:29:45 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #35 on: July 16, 2012, 10:45:40 AM »
Code corrected once more... No need to convert old heavy 2d polyline to lwpolyline...

Both variants are acceptable, though I suggest smaller one - MR variant...

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

:)

M.R. on Youtube

chlh_jd

  • Guest
Re: vlax-curve-getfurthestpointfrom
« Reply #36 on: July 24, 2012, 02:33:06 AM »
For Circle , this way ?
Code: [Select]
((= "CIRCLE" etype)
  ((lambda (p c r)
     (polar p (angle p c) (* 2. r))
   )
    (vlax-curve-getclosestpointto curve point)
    (cdr (Assoc 10 elst))
    (cdr (assoc 40 elst))
  )
)

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #37 on: August 21, 2012, 08:42:04 AM »
For Circle , this way ?
Code: [Select]
((= "CIRCLE" etype)
  ((lambda (p c r)
     (polar p (angle p c) (* 2. r))
   )
    (vlax-curve-getclosestpointto curve point)
    (cdr (Assoc 10 elst))
    (cdr (assoc 40 elst))
  )
)

Yes, chlh_jd, that would sure solve the case, but I wonder how no one didn't saw that in my code - Zoltan's also is written (repeat (1- samples) ...), and should be (repeat samples ...)... So here is my slightly modifications :

Code - Auto/Visual Lisp: [Select]
  1. (Defun MR-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag)
  2. (SetQ samples 200
  3.      tolerance 1e-14
  4. )
  5.  
  6. (Defun FurthestParameter (SP EP / seg params par furthest f ff )
  7. (SetQ params (List SP))
  8. (SetQ seg 0.0)
  9.  
  10. (Defun IsFurther ( A B P )
  11.  (>= (Distance A P) (Distance B P))
  12. )
  13.  
  14. (Repeat samples
  15.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  16. )
  17.  
  18. (SetQ furthest (Car (SetQ par
  19.                 (Vl-Sort-I
  20.                  params
  21.                  (Function
  22.                   (Lambda (a b)
  23.                    (IsFurther
  24.                     (VLAX-Curve-GetPointAtParam CURVE a)
  25.                     (VLAX-Curve-GetPointAtParam CURVE b)
  26.                     POINT
  27.                    )
  28.                   )
  29.                  )
  30.                 ))
  31.                )
  32. )
  33.  
  34. (setq f (nth furthest params))
  35.  
  36. (If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
  37.  (setq ff (FurthestParameter
  38.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  39.    (Nth furthest params)
  40.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  41.     (Nth (Cadr par) params)
  42.     (Nth (Caddr par) params)
  43.    )
  44.   )
  45.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  46.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  47.     (Nth (Cadr par) params)
  48.     (Nth (Caddr par) params)
  49.    )
  50.    (Nth furthest params)
  51.   )
  52.  ))
  53.  (setq ff (Nth furthest params))
  54. )
  55.  
  56. ff
  57. )
  58.  
  59.   CURVE
  60.   (FurthestParameter
  61.   )
  62.  )
  63.  
  64. )
  65.  
  66. (defun vlax-curve-getfurthestpointfrom ( CURVE POINT / elst etype 2dtype lstn )
  67.  
  68. (Defun IsFurther ( A B P )
  69.  (>= (Distance A P) (Distance B P))
  70. )
  71.  
  72. (defun _polyvertices ( lst )
  73.   (_vertices2 (entnext (cdr (assoc -1 lst))))
  74. )
  75.  
  76. (defun _vertices2 ( e )
  77.   (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
  78.     (progn
  79.       (setq lstn (cons (assoc 10 (entget e)) lstn))
  80.       (setq lstn (cons (assoc 42 (entget e)) lstn))
  81.       (_vertices2 (entnext e))
  82.     )
  83.   )
  84.   (reverse lstn)
  85. )
  86.  
  87. (defun member-fuzz (expr lst fuzz)
  88.   (while (and lst (not (equal (car lst) expr fuzz)))
  89.     (setq lst (cdr lst))
  90.   )
  91.   lst
  92. )
  93.  
  94. (defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  95.   (setq enpar (vlax-curve-getendparam ent))
  96.   (setq n -1)
  97.   (repeat (fix enpar)
  98.     (setq n (1+ n))
  99.     (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
  100.     (setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
  101.     (if (/= bulge 0.0)
  102.       (progn
  103.         (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
  104.         (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
  105.         (setq cenlst (cons cen cenlst))
  106.       )
  107.     )
  108.   )
  109.   (reverse cenlst)
  110. )
  111.  
  112. (SetQ elst (entget CURVE))
  113. (SetQ etype (Cdr (Assoc 0 elst)))
  114.  
  115. ((= "XLINE" etype)
  116.  nil
  117. )
  118. ((= "RAY" etype)
  119.  nil
  120. )
  121. ((= "LINE" etype)
  122.  (If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
  123.   (Cdr (Assoc 10 elst))
  124.   (Cdr (Assoc 11 elst))
  125.  )
  126. )
  127. ((And
  128.   (= "ARC" etype)
  129.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  130.  )
  131.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  132. )
  133. ((And
  134.   (= "CIRCLE" etype)
  135.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  136.  )
  137.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  138. )
  139. ((And
  140.   (= "ELLIPSE" etype)
  141.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  142.  )
  143.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  144. )
  145. ((And
  146.   (= "LWPOLYLINE" etype)
  147.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  148.  )
  149.  (Car
  150.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  151.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  152.   )
  153.  )
  154. )
  155. ((And
  156.   (= "LWPOLYLINE" etype)
  157.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  158.   (member-fuzz POINT (_plcents CURVE) 1e-8)
  159.  )
  160.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  161. )
  162. ((And
  163.   (= "POLYLINE" etype)
  164.   (SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
  165.   (SetQ elst (_polyvertices elst))
  166.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  167.   (If (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents CURVE) 1e-8))
  168.  )
  169.  (MR-Curve-GetFurthestPointFrom CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  170. )
  171. ((And
  172.   (= "POLYLINE" etype)
  173.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  174.  )
  175.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  176. )
  177. ((And
  178.   (= "POLYLINE" etype)
  179.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  180.  )
  181.  (Car
  182.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  183.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  184.   )
  185.  )
  186. )
  187. (T
  188.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  189. )
  190. )
  191. )
  192.  

And I also made revision for usage without spline objects - little slower, but exact results (too bad you can't draw circle that tang snap spline)... Autodesk should seriously revise spline osnaps - you can't get int snap when self-crossed and you can't use tan snap with circles like in this mine case...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #38 on: August 21, 2012, 10:08:44 AM »
And here is my most recent revision with circle subfunction and with normal subfunction combined into single (vlax-curve-getfurthestpointfrom)... Little slower, but till now probably the most exact results - only thing that remains is spline, but here also result is near expected but not exact...

Code - Auto/Visual Lisp: [Select]
  1. (Defun MR-Curve-GetFurthestPointFromCircle ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag pt )
  2. (SetQ samples 200
  3.      tolerance 1e-14
  4. )
  5.  
  6. (Defun FurthestParameter (SP EP / seg params par furthest f ff )
  7. (SetQ params (List SP))
  8. (SetQ seg 0.0)
  9.  
  10. (Defun IsFurther ( A B P )
  11.  (>= (Distance A P) (Distance B P))
  12. )
  13.  
  14. (Repeat samples
  15.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  16. )
  17.  
  18. (SetQ furthest (Car (SetQ par
  19.                 (Vl-Sort-I
  20.                  params
  21.                  (Function
  22.                   (Lambda (a b)
  23.                    (IsFurther
  24.                     (VLAX-Curve-GetPointAtParam CURVE a)
  25.                     (VLAX-Curve-GetPointAtParam CURVE b)
  26.                     POINT
  27.                    )
  28.                   )
  29.                  )
  30.                 ))
  31.                )
  32. )
  33.  
  34. (setq f (nth furthest params))
  35.  
  36. (If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
  37.  (setq ff (FurthestParameter
  38.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  39.    (Nth furthest params)
  40.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  41.     (Nth (Cadr par) params)
  42.     (Nth (Caddr par) params)
  43.    )
  44.   )
  45.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  46.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  47.     (Nth (Cadr par) params)
  48.     (Nth (Caddr par) params)
  49.    )
  50.    (Nth furthest params)
  51.   )
  52.  ))
  53.  (setq ff (Nth furthest params))
  54. )
  55.  
  56. ff
  57. )
  58.  
  59. (Setq pt
  60.   CURVE
  61.   (FurthestParameter
  62.   )
  63.  )
  64. )
  65. (setq osm (getvar 'osmode))
  66. (setvar 'osmode 257)
  67. (vl-cmdf "_.CIRCLE" point pt)
  68. (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object (entlast)) acExtendNone))
  69. (setvar 'osmode osm)
  70. pt
  71. )
  72.  
  73. (Defun MR-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag)
  74. (SetQ samples 200
  75.      tolerance 1e-14
  76. )
  77.  
  78. (Defun FurthestParameter (SP EP / seg params par furthest f ff )
  79. (SetQ params (List SP))
  80. (SetQ seg 0.0)
  81.  
  82. (Defun IsFurther ( A B P )
  83.  (>= (Distance A P) (Distance B P))
  84. )
  85.  
  86. (Repeat samples
  87.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  88. )
  89.  
  90. (SetQ furthest (Car (SetQ par
  91.                 (Vl-Sort-I
  92.                  params
  93.                  (Function
  94.                   (Lambda (a b)
  95.                    (IsFurther
  96.                     (VLAX-Curve-GetPointAtParam CURVE a)
  97.                     (VLAX-Curve-GetPointAtParam CURVE b)
  98.                     POINT
  99.                    )
  100.                   )
  101.                  )
  102.                 ))
  103.                )
  104. )
  105.  
  106. (setq f (nth furthest params))
  107.  
  108. (If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
  109.  (setq ff (FurthestParameter
  110.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  111.    (Nth furthest params)
  112.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  113.     (Nth (Cadr par) params)
  114.     (Nth (Caddr par) params)
  115.    )
  116.   )
  117.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  118.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  119.     (Nth (Cadr par) params)
  120.     (Nth (Caddr par) params)
  121.    )
  122.    (Nth furthest params)
  123.   )
  124.  ))
  125.  (setq ff (Nth furthest params))
  126. )
  127.  
  128. ff
  129. )
  130.  
  131.   CURVE
  132.   (FurthestParameter
  133.   )
  134.  )
  135.  
  136. )
  137.  
  138. (defun vlax-curve-getfurthestpointfrom ( CURVE POINT / elst etype 2dtype lstn )
  139.  
  140. (Defun IsFurther ( A B P )
  141.  (>= (Distance A P) (Distance B P))
  142. )
  143.  
  144. (defun _polyvertices ( lst )
  145.   (_vertices2 (entnext (cdr (assoc -1 lst))))
  146. )
  147.  
  148. (defun _vertices2 ( e )
  149.   (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
  150.     (progn
  151.       (setq lstn (cons (assoc 10 (entget e)) lstn))
  152.       (setq lstn (cons (assoc 42 (entget e)) lstn))
  153.       (_vertices2 (entnext e))
  154.     )
  155.   )
  156.   (reverse lstn)
  157. )
  158.  
  159. (defun member-fuzz (expr lst fuzz)
  160.   (while (and lst (not (equal (car lst) expr fuzz)))
  161.     (setq lst (cdr lst))
  162.   )
  163.   lst
  164. )
  165.  
  166. (defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  167.   (setq enpar (vlax-curve-getendparam ent))
  168.   (setq n -1)
  169.   (repeat (fix enpar)
  170.     (setq n (1+ n))
  171.     (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
  172.     (setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
  173.     (if (/= bulge 0.0)
  174.       (progn
  175.         (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
  176.         (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
  177.         (setq cenlst (cons cen cenlst))
  178.       )
  179.     )
  180.   )
  181.   (reverse cenlst)
  182. )
  183.  
  184. (SetQ elst (entget CURVE))
  185. (SetQ etype (Cdr (Assoc 0 elst)))
  186.  
  187. ((= "XLINE" etype)
  188.  nil
  189. )
  190. ((= "RAY" etype)
  191.  nil
  192. )
  193. ((= "LINE" etype)
  194.  (If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
  195.   (Cdr (Assoc 10 elst))
  196.   (Cdr (Assoc 11 elst))
  197.  )
  198. )
  199. ((And
  200.   (= "ARC" etype)
  201.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  202.  )
  203.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  204. )
  205. ((And
  206.   (= "CIRCLE" etype)
  207.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  208.  )
  209.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  210. )
  211. ((And
  212.   (= "ELLIPSE" etype)
  213.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  214.  )
  215.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  216. )
  217. ((And
  218.   (= "LWPOLYLINE" etype)
  219.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  220.  )
  221.  (Car
  222.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  223.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  224.   )
  225.  )
  226. )
  227. ((And
  228.   (= "LWPOLYLINE" etype)
  229.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  230.   (member-fuzz POINT (_plcents CURVE) 1e-8)
  231.  )
  232.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  233. )
  234. ((And
  235.   (= "POLYLINE" etype)
  236.   (SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
  237.   (SetQ elst (_polyvertices elst))
  238.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  239.   (If (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents CURVE) 1e-8))
  240.  )
  241.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  242. )
  243. ((And
  244.   (= "POLYLINE" etype)
  245.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  246.  )
  247.  (MR-Curve-GetFurthestPointFromCircle CURVE POINT)
  248. )
  249. ((And
  250.   (= "POLYLINE" etype)
  251.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  252.  )
  253.  (Car
  254.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  255.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  256.   )
  257.  )
  258. )
  259. (T
  260.  (MR-Curve-GetFurthestPointFrom CURVE POINT)
  261. )
  262. )
  263. )
  264.  

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #39 on: August 22, 2012, 05:44:33 AM »
My final revision, you should get exact result and for splines...

Code - Auto/Visual Lisp: [Select]
  1. (Defun MR-Curve-GetFurthestPointFromCircleSpline ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag pt )
  2. (SetQ samples 200
  3.      tolerance 1e-8
  4. )
  5.  
  6. (Defun FurthestParameter (SP EP / seg params par furthest f ff ci cidata rad r rr k )
  7. (SetQ params (List SP))
  8. (SetQ seg 0.0)
  9.  
  10. (Defun IsFurther ( A B P )
  11.  (>= (Distance A P) (Distance B P))
  12. )
  13.  
  14. (Repeat samples
  15.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  16. )
  17.  
  18. (SetQ furthest (Car (SetQ par
  19.                 (Vl-Sort-I
  20.                  params
  21.                  (Function
  22.                   (Lambda (a b)
  23.                    (IsFurther
  24.                     (VLAX-Curve-GetPointAtParam CURVE a)
  25.                     (VLAX-Curve-GetPointAtParam CURVE b)
  26.                     POINT
  27.                    )
  28.                   )
  29.                  )
  30.                 ))
  31.                )
  32. )
  33.  
  34. (setq f (nth furthest params))
  35.  
  36. (If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
  37.  (setq ff (FurthestParameter
  38.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  39.    (Nth furthest params)
  40.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  41.     (Nth (Cadr par) params)
  42.     (Nth (Caddr par) params)
  43.    )
  44.   )
  45.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  46.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  47.     (Nth (Cadr par) params)
  48.     (Nth (Caddr par) params)
  49.    )
  50.    (Nth furthest params)
  51.   )
  52.  ))
  53.  (setq ff (Nth furthest params))
  54. )
  55.  
  56. ff
  57. )
  58.  
  59. (Setq pt
  60.   CURVE
  61.   (FurthestParameter
  62.   )
  63.  )
  64. )
  65.  
  66. (setq osm (getvar 'osmode))
  67. (setvar 'osmode 0)
  68. (vl-cmdf "_.CIRCLE" point pt)
  69. (setq rad (cdr (assoc 40 (setq cidata (entget (setq ci (entlast)))))))
  70. (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
  71. (setq k 0.0)
  72. (while (> (length pt) 3)
  73.  (setq r (+ rad (* 1e-8 (setq k (1+ k)))))
  74.  (entmod (subst (cons 40 r) (assoc 40 cidata) cidata))
  75.  (entupd ci)
  76.  (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
  77. )
  78. (setq k 0.0)
  79. (setq r (cdr (assoc 40 cidata)))
  80. (while (/= (length pt) 3)
  81.  (setq rr (- r (* 1e-10 (setq k (1+ k)))))
  82.  (entmod (subst (cons 40 rr) (assoc 40 cidata) cidata))
  83.  (entupd ci)
  84.  (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
  85. )
  86. (entdel ci)
  87. (setvar 'osmode osm)
  88. pt
  89. )
  90.  
  91. (Defun MR-Curve-GetFurthestPointFromCircle ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag pt )
  92. (SetQ samples 200
  93.      tolerance 1e-8
  94. )
  95.  
  96. (Defun FurthestParameter (SP EP / seg params par furthest f ff )
  97. (SetQ params (List SP))
  98. (SetQ seg 0.0)
  99.  
  100. (Defun IsFurther ( A B P )
  101.  (>= (Distance A P) (Distance B P))
  102. )
  103.  
  104. (Repeat samples
  105.  (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
  106. )
  107.  
  108. (SetQ furthest (Car (SetQ par
  109.                 (Vl-Sort-I
  110.                  params
  111.                  (Function
  112.                   (Lambda (a b)
  113.                    (IsFurther
  114.                     (VLAX-Curve-GetPointAtParam CURVE a)
  115.                     (VLAX-Curve-GetPointAtParam CURVE b)
  116.                     POINT
  117.                    )
  118.                   )
  119.                  )
  120.                 ))
  121.                )
  122. )
  123.  
  124. (setq f (nth furthest params))
  125.  
  126. (If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
  127.  (setq ff (FurthestParameter
  128.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  129.    (Nth furthest params)
  130.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  131.     (Nth (Cadr par) params)
  132.     (Nth (Caddr par) params)
  133.    )
  134.   )
  135.   (If (< (Nth furthest params) (Nth (Cadr par) params))
  136.    (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
  137.     (Nth (Cadr par) params)
  138.     (Nth (Caddr par) params)
  139.    )
  140.    (Nth furthest params)
  141.   )
  142.  ))
  143.  (setq ff (Nth furthest params))
  144. )
  145.  
  146. ff
  147. )
  148.  
  149. (Setq pt
  150.   CURVE
  151.   (FurthestParameter
  152.   )
  153.  )
  154. )
  155. (setq osm (getvar 'osmode))
  156. (setvar 'osmode 257)
  157. (vl-cmdf "_.CIRCLE" point pt)
  158. (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object (entlast)) acExtendNone))
  159. (setvar 'osmode osm)
  160. pt
  161. )
  162.  
  163. (defun vlax-curve-getfurthestpointfrom ( CURVE POINT / elst etype 2dtype lstn )
  164.  
  165. (Defun IsFurther ( A B P )
  166.  (>= (Distance A P) (Distance B P))
  167. )
  168.  
  169. (defun _polyvertices ( lst )
  170.   (_vertices2 (entnext (cdr (assoc -1 lst))))
  171. )
  172.  
  173. (defun _vertices2 ( e )
  174.   (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
  175.     (progn
  176.       (setq lstn (cons (assoc 10 (entget e)) lstn))
  177.       (setq lstn (cons (assoc 42 (entget e)) lstn))
  178.       (_vertices2 (entnext e))
  179.     )
  180.   )
  181.   (reverse lstn)
  182. )
  183.  
  184. (defun member-fuzz (expr lst fuzz)
  185.   (while (and lst (not (equal (car lst) expr fuzz)))
  186.     (setq lst (cdr lst))
  187.   )
  188.   lst
  189. )
  190.  
  191. (defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  192.   (setq enpar (vlax-curve-getendparam ent))
  193.   (setq n -1)
  194.   (repeat (fix enpar)
  195.     (setq n (1+ n))
  196.     (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
  197.     (setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
  198.     (if (/= bulge 0.0)
  199.       (progn
  200.         (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
  201.         (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
  202.         (setq cenlst (cons cen cenlst))
  203.       )
  204.     )
  205.   )
  206.   (reverse cenlst)
  207. )
  208.  
  209. (SetQ elst (entget CURVE))
  210. (SetQ etype (Cdr (Assoc 0 elst)))
  211.  
  212. ((= "XLINE" etype)
  213.  nil
  214. )
  215. ((= "RAY" etype)
  216.  nil
  217. )
  218. ((= "LINE" etype)
  219.  (If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
  220.   (Cdr (Assoc 10 elst))
  221.   (Cdr (Assoc 11 elst))
  222.  )
  223. )
  224. ((And
  225.   (= "ARC" etype)
  226.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  227.  )
  228.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  229. )
  230. ((And
  231.   (= "CIRCLE" etype)
  232.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  233.  )
  234.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  235. )
  236. ((And
  237.   (= "ELLIPSE" etype)
  238.   (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
  239.  )
  240.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  241. )
  242. ((And
  243.   (= "LWPOLYLINE" etype)
  244.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  245.  )
  246.  (Car
  247.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  248.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  249.   )
  250.  )
  251. )
  252. ((And
  253.   (= "LWPOLYLINE" etype)
  254.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  255.   (member-fuzz POINT (_plcents CURVE) 1e-8)
  256.  )
  257.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  258. )
  259. ((And
  260.   (= "POLYLINE" etype)
  261.   (SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
  262.   (SetQ elst (_polyvertices elst))
  263.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  264.   (If (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents CURVE) 1e-8))
  265.  )
  266.  (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
  267. )
  268. ((And
  269.   (= "POLYLINE" etype)
  270.   (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  271.  )
  272.  (MR-Curve-GetFurthestPointFromCircle CURVE POINT)
  273. )
  274. ((And
  275.   (= "POLYLINE" etype)
  276.   (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
  277.  )
  278.  (Car
  279.   (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
  280.            (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  281.   )
  282.  )
  283. )
  284. (T
  285.  (MR-Curve-GetFurthestPointFromCircleSpline CURVE POINT)
  286. )
  287. )
  288. )
  289.  

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #40 on: August 22, 2012, 07:11:11 AM »
Important note :

- For 3d curve and point you should use :
http://www.theswamp.org/index.php?topic=42246.msg477514#msg477514
vlax-curve-getfurthestpointfrom-MR-rev.lsp
and result may have imperfections...

- For 2d curve and point that lie in WCS you should use :
http://www.theswamp.org/index.php?topic=42246.msg477659#msg477659
vlax-curve-getfurthestpointfrom-MR-revision-new.lsp
and result should be exactly correct...

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #41 on: August 22, 2012, 01:53:56 PM »
Although it not too much wise, combined into single function (vlax-curve-getfurthestpointfrom) for 2d geometry + 3d geometry.

M.R.

[EDIT: some minor modifications - till now there was 14 downloads - replaced *.lsp]
« Last Edit: August 28, 2012, 11:11:22 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

chlh_jd

  • Guest
Re: vlax-curve-getfurthestpointfrom
« Reply #42 on: August 22, 2012, 04:44:24 PM »
For Circle , this way ?
Code: [Select]
((= "CIRCLE" etype)
  ((lambda (p c r)
     (polar p (angle p c) (* 2. r))
   )
    (vlax-curve-getclosestpointto curve point)
    (cdr (Assoc 10 elst))
    (cdr (assoc 40 elst))
  )
)

Yes, chlh_jd, that would sure solve the case, but I wonder how no one didn't saw that in my code - Zoltan's also is written (repeat (1- samples) ...), and should be (repeat samples ...)... So here is my slightly modifications :
Glad you can be in favor of .
However , If distance from point to curve is far enough away, such as must use light-years to desribe , this maximum distance lost meaning . I guess this is why autocad  put the 'getfurthestpointfrom' function  into .

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #43 on: August 23, 2012, 07:12:54 AM »
Glad you can be in favor of .
However , If distance from point to curve is far enough away, such as must use light-years to desribe , this maximum distance lost meaning . I guess this is why autocad  put the 'getfurthestpointfrom' function  into .

I intended to create this function with some purpose in process of working with AutoCAD. I guess no one will draw entities so far away from checked point... As a matter a fact I already posted one possible usage of this function on www.cadtutor.net (you may google it) and it was with normal demands of CAD (Computer Aided Design)...

BTW. I changed my last attached *.lsp with some minor modifications (checked point may not be in plane, but if curve is, it finds furthest point from projected check point onto WCS using (vlax-curve-getfurthestpointfrom2d) subfunction... Also turned off echoing of (vl-cmdf "_.CIRCLE" point pt) while computing inside subfunctions...

Quote
And finally make sure checked point is transformed into WCS coordinates before calculations begin (trans point 1 0) - so you may start function no matter what UCS is currently active...

[EDIT : I've checked (vlax-curve-getclosestpointto) for some random UCS, and it assumed that checked point is in WCS and returned point in WCS, so I returned back my function to work the same way...]

M.R.
« Last Edit: August 23, 2012, 07:49:37 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: vlax-curve-getfurthestpointfrom
« Reply #44 on: August 23, 2012, 11:57:15 AM »
I've decided to post *.lsp in code view since it was modified several times... Sorry for this, but this modifications are unavoidable...

Code: [Select]
(Defun MR-Curve-GetFurthestPointFromCircle ( CURVE POINT / osm cmde samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag pt )
(SetQ samples 200
     tolerance 1e-8
)
 
(Defun FurthestParameter (SP EP / seg params par furthest f ff ci cidata rad r rr k )
(SetQ params (List SP))
(SetQ seg 0.0)

(Defun IsFurther ( A B P )
 (>= (Distance A P) (Distance B P))
)
 
(Repeat samples
 (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
)
 
(SetQ furthest (Car (SetQ par
                (Vl-Sort-I
                 params
                 (Function
                  (Lambda (a b)
                   (IsFurther
                    (VLAX-Curve-GetPointAtParam CURVE a)
                    (VLAX-Curve-GetPointAtParam CURVE b)
                    POINT
                   )
                  )
                 )
                ))
               )
)

(setq f (nth furthest params))

(If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
 (setq ff (FurthestParameter
  (If (< (Nth furthest params) (Nth (Cadr par) params))
   (Nth furthest params)
   (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
    (Nth (Cadr par) params)
    (Nth (Caddr par) params)
   )
  )
  (If (< (Nth furthest params) (Nth (Cadr par) params))
   (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
    (Nth (Cadr par) params)
    (Nth (Caddr par) params)
   )
   (Nth furthest params)
  )
 ))
 (setq ff (Nth furthest params))
)

ff
)

(Setq pt
 (VLAX-Curve-GetPointAtParam
  CURVE
  (FurthestParameter
   (VLAX-Curve-GetStartParam CURVE)
   (VLAX-Curve-GetEndParam CURVE)
  )
 )
)

(setq cmde (getvar 'cmdecho))
(setq osm (getvar 'osmode))
(setvar 'cmdecho 0)
(setvar 'osmode 0)
(vl-cmdf "_.CIRCLE" (trans point 0 1) (trans pt 0 1))
(setq rad (cdr (assoc 40 (setq cidata (entget (setq ci (entlast)))))))
(setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
(setq k 0.0)
(while (> (length pt) 3)
 (setq r (+ rad (* 1e-4 (setq k (1+ k)))))
 (entmod (subst (cons 40 r) (assoc 40 cidata) cidata))
 (entupd ci)
 (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
)
(setq k 0.0)
(setq r (cdr (assoc 40 cidata)))
(while (/= (length pt) 3)
 (setq rr (- r (* 1e-8 (setq k (1+ k)))))
 (entmod (subst (cons 40 rr) (assoc 40 cidata) cidata))
 (entupd ci)
 (setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
)
(entdel ci)
(setvar 'osmode osm)
(setvar 'cmdecho cmde)
(list (car pt) (cadr pt) (caddr pt))
)

(defun vlax-curve-getfurthestpointfrom2d ( CURVE POINT / elst etype 2dtype lstn )

(Defun IsFurther ( A B P )
 (>= (Distance A P) (Distance B P))
)
 
(defun _polyvertices ( lst )
  (_vertices2 (entnext (cdr (assoc -1 lst))))
)
 
(defun _vertices2 ( e )
  (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
    (progn
      (setq lstn (cons (assoc 10 (entget e)) lstn))
      (setq lstn (cons (assoc 42 (entget e)) lstn))
      (_vertices2 (entnext e))
    )
  )
  (reverse lstn)
)
 
(defun member-fuzz (expr lst fuzz)
  (while (and lst (not (equal (car lst) expr fuzz)))
    (setq lst (cdr lst))
  )
  lst
)
 
(defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  (setq enpar (vlax-curve-getendparam ent))
  (setq n -1)
  (repeat (fix enpar)
    (setq n (1+ n))
    (setq p1 (vlax-curve-getpointatparam ent (float n)))
    (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
    (setq bulge (vla-getbulge (if (eq (type ent) 'ENAME) (vlax-ename->vla-object ent) ent) (float n)))
    (if (/= bulge 0.0)
      (progn
        (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
        (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
        (setq cenlst (cons cen cenlst))
      )
    )
  )
  (reverse cenlst)
)
 
(SetQ elst (entget CURVE))
(SetQ etype (Cdr (Assoc 0 elst)))

(Cond
((And
  (= "ARC" etype)
  (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
  (= "CIRCLE" etype)
  (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
  (= "ELLIPSE" etype)
  (Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
  (= "LWPOLYLINE" etype)
  (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
 )
 (Car
  (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
           (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  )
 )
)
((And
  (= "LWPOLYLINE" etype)
  (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8)
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
  (= "LWPOLYLINE" etype)
  (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  (not (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8))
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE POINT)
)
((And
  (= "POLYLINE" etype)
  (SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
  (SetQ elst (_polyvertices elst))
  (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  (and (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8))
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
  (= "POLYLINE" etype)
  (not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
  (not (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8))
 )
 (MR-Curve-GetFurthestPointFromCircle CURVE POINT)
)
((And
  (= "POLYLINE" etype)
  (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
 )
 (Car
  (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
           (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  )
 )
)
(T
 (MR-Curve-GetFurthestPointFromCircle CURVE POINT)
)
)
)

(Defun MR-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag )
(SetQ samples 200
     tolerance 1e-14
)
 
(Defun FurthestParameter (SP EP / seg params par furthest f ff )
(SetQ params (List SP))
(SetQ seg 0.0)

(Defun IsFurther ( A B P )
 (>= (Distance A P) (Distance B P))
)
 
(Repeat samples
 (SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
)
 
(SetQ furthest (Car (SetQ par
                (Vl-Sort-I
                 params
                 (Function
                  (Lambda (a b)
                   (IsFurther
                    (VLAX-Curve-GetPointAtParam CURVE a)
                    (VLAX-Curve-GetPointAtParam CURVE b)
                    POINT
                   )
                  )
                 )
                ))
               )
)

(setq f (nth furthest params))

(If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
 (setq ff (FurthestParameter
  (If (< (Nth furthest params) (Nth (Cadr par) params))
   (Nth furthest params)
   (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
    (Nth (Cadr par) params)
    (Nth (Caddr par) params)
   )
  )
  (If (< (Nth furthest params) (Nth (Cadr par) params))
   (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
    (Nth (Cadr par) params)
    (Nth (Caddr par) params)
   )
   (Nth furthest params)
  )
 ))
 (setq ff (Nth furthest params))
)

ff
)
 
 (VLAX-Curve-GetPointAtParam
  CURVE
  (FurthestParameter
   (VLAX-Curve-GetStartParam CURVE)
   (VLAX-Curve-GetEndParam CURVE)
  )
 )
 
)
 
(defun vlax-curve-getfurthestpointfrom3d ( CURVE POINT / elst etype 2dtype lstn )

(Defun IsFurther ( A B P )
 (>= (Distance A P) (Distance B P))
)
 
(defun _polyvertices ( lst )
  (_vertices2 (entnext (cdr (assoc -1 lst))))
)
 
(defun _vertices2 ( e )
  (if (eq "VERTEX" (cdr (assoc 0 (entget e))))
    (progn
      (setq lstn (cons (assoc 10 (entget e)) lstn))
      (setq lstn (cons (assoc 42 (entget e)) lstn))
      (_vertices2 (entnext e))
    )
  )
  (reverse lstn)
)
 
(defun member-fuzz (expr lst fuzz)
  (while (and lst (not (equal (car lst) expr fuzz)))
    (setq lst (cdr lst))
  )
  lst
)
 
(defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
  (setq enpar (vlax-curve-getendparam ent))
  (setq n -1)
  (repeat (fix enpar)
    (setq n (1+ n))
    (setq p1 (vlax-curve-getpointatparam ent (float n)))
    (setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
    (setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
    (if (/= bulge 0.0)
      (progn
        (setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
        (setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
        (setq cenlst (cons cen cenlst))
      )
    )
  )
  (reverse cenlst)
)
 
(SetQ elst (entget CURVE))
(SetQ etype (Cdr (Assoc 0 elst)))

(Cond
((= "XLINE" etype)
 nil
)
((= "RAY" etype)
 nil
)
((= "LINE" etype)
 (If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
  (Cdr (Assoc 10 elst))
  (Cdr (Assoc 11 elst))
 )
)
((And
  (= "POLYLINE" etype)
  (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
 )
 (Car
  (VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
           (Function (Lambda ( a b ) (IsFurther a b POINT)) )
  )
 )
)
(T
 (MR-Curve-GetFurthestPointFrom CURVE POINT)
)
)
)

;; Vector Cross Product - Lee Mac
;; Args: u,v - vectors in R^3

(defun v^v ( u v )
  (list
    (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
    (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))
    (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
  )
)

;; Collinear-p  -  Lee Mac
;; Returns T if p1,p2,p3 are collinear

(defun LM:Collinear-p ( p1 p2 p3 )
    (
        (lambda ( a b c )
            (or
                (equal (+ a b) c 1e-8)
                (equal (+ b c) a 1e-8)
                (equal (+ c a) b 1e-8)
            )
        )
        (distance p1 p2) (distance p2 p3) (distance p1 p3)
    )
)

;; Project Point onto Plane  -  Lee Mac
;; Projects pt onto the plane defined by its origin and normal

(defun LM:ProjectPointToPlane ( pt org nm )
    (setq pt  (trans pt  0 nm)
          org (trans org 0 nm)
    )
    (trans (list (car pt) (cadr pt) (caddr org)) nm 0)
)

(defun vlax-curve-getfurthestpointfrom ( curve point / vla-curve flagarc flaglw cmde pt pt1 pt2 pt3 pt4 )
  (setq cmde (getvar 'cmdecho))
  (if (eq (type curve) 'VLA-OBJECT)
    (progn
      (setq vla-curve curve)
      (setq curve (vlax-vla-object->ename vla-curve))
    )
  )
  (if (eq (cdr (assoc 0 (entget curve))) "ARC")
    (progn
      (setq flagarc T)
      (setvar 'cmdecho 0)
      (vl-cmdf "_.COPY" curve "" '(0.0 0.0 0.0) '(0.0 0.0 0.0))
      (vl-cmdf "_.PEDIT" (entlast) "" "")
      (setq curve (entlast))
      (setvar 'cmdecho cmde)
    )
  )
  (if (eq (cdr (assoc 0 (entget curve))) "LWPOLYLINE")
    (progn
      (setq flaglw T)
      (setvar 'cmdecho 0)
      (vl-cmdf "_.CONVERTPOLY" "H" curve "")
      (setq vla-curve (vlax-ename->vla-object curve))
      (setvar 'cmdecho cmde)
    )
  )
  (setq pt1 (vlax-curve-getpointatparam curve (+ (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve)) (* 1.0 (/ (- (if (not (vl-catch-all-apply 'vlax-curve-getendparam (list curve))) 3.0 (vlax-curve-getendparam curve)) (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve))) 3.0)))))
  (setq pt2 (vlax-curve-getpointatparam curve (+ (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve)) (* 2.0 (/ (- (if (not (vl-catch-all-apply 'vlax-curve-getendparam (list curve))) 3.0 (vlax-curve-getendparam curve)) (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve))) 3.0)))))
  (setq pt3 (vlax-curve-getpointatparam curve (+ (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve)) (* 3.0 (/ (- (if (not (vl-catch-all-apply 'vlax-curve-getendparam (list curve))) 3.0 (vlax-curve-getendparam curve)) (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve))) 3.0)))))
  (setq pt4 (vlax-curve-getstartpoint curve))
  (if (and (not (LM:Collinear-p pt1 pt2 pt3)) (not (LM:Collinear-p pt1 pt2 pt4)) (vlax-curve-isplanar curve))
    (cond ((not (and (equal (caddr pt1) 0.0 1e-8) (equal (caddr pt2) 0.0 1e-8) (equal (caddr pt3) 0.0 1e-8) (equal (caddr pt4) 0.0 1e-8)))
      (progn
        (setvar 'cmdecho 0)
        (vl-cmdf "_.UCS" "w")
        (vl-cmdf "_.UCS" "za" "" (v^v (mapcar '- pt2 pt1) (mapcar '- pt3 pt1)))
        (vl-cmdf "_.UCS" "m" (trans pt1 0 1))
        (setq pt (vlax-curve-getfurthestpointfrom2d curve (LM:ProjectPointToPlane point (trans '(0.0 0.0 0.0) 1 0) (mapcar '- (trans '(0.0 0.0 1.0) 1 0) (trans '(0.0 0.0 0.0) 1 0)))))
        (vl-cmdf "_.UCS" "p")
        (vl-cmdf "_.UCS" "p")
        (vl-cmdf "_.UCS" "p")
        (setvar 'cmdecho cmde)
      ))
      ((and (equal (caddr pt1) 0.0 1e-8) (equal (caddr pt2) 0.0 1e-8) (equal (caddr pt3) 0.0 1e-8) (equal (caddr pt4) 0.0 1e-8) (eq (getvar 'worlducs) 0))
      (progn
        (setvar 'cmdecho 0)
        (vl-cmdf "_.UCS" "w")
        (setq pt (vlax-curve-getfurthestpointfrom2d curve (LM:ProjectPointToPlane point '(0.0 0.0 0.0) '(0.0 0.0 1.0))))
        (vl-cmdf "_.UCS" "p")
        (setvar 'cmdecho cmde)
      ))
      ((and (equal (caddr pt1) 0.0 1e-8) (equal (caddr pt2) 0.0 1e-8) (equal (caddr pt3) 0.0 1e-8) (equal (caddr pt4) 0.0 1e-8) (eq (getvar 'worlducs) 1))
      (setq pt (vlax-curve-getfurthestpointfrom2d curve (LM:ProjectPointToPlane point '(0.0 0.0 0.0) '(0.0 0.0 1.0))))
      )
    )
    (setq pt (vlax-curve-getfurthestpointfrom3d curve point))
  )
  (setvar 'cmdecho 0)
  (gc)
  (if flaglw (vl-cmdf "_.CONVERTPOLY" "L" curve ""))
  (if flagarc (vl-cmdf "_.ERASE" (entlast) ""))
  (setvar 'cmdecho cmde)
  pt
)

M.R.
« Last Edit: August 28, 2012, 11:10:51 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube