points density - dense.lsp - overlapping points and speed issue

[marko_ribar]

Hi all, recently I tried to make routine for making greater density of points that are to be used in generating terrain model. I know one desirable process that I've already tried (thread ab surveying points here on www.cadtutor.net) with DTM routine for 3DFACEs generation, AC (AutoCurve) routine that had small bug - line : (inters pt1 pt2 pt3 pt4) should be (inters pt1 pt2 pt3 pt4 nil) within one subfunction (I corrected this and that's now OK), LV routine for making mesh from sections over exploded polylines isohypses (equal elevation) from before used AC on 3DFACEs from DTM, and finally M2S (mesh2solid) routine for making 3D solid terrain... Anyway, my question is ab routine I made... Now it gives approximately desired results with less than 1000 points... I want to speed somehow process of calculation - code optimization and to allow more than 1000 points to be considered for routine calculations (this is even now possible but process is so slow - time consumption is greater with every single point added more for calculation consideration)... And one more thing, if process of repeating execution of routine is performed (4-5 times on starting 4 points) at the end when used command OVERKILL it removes duplicated points, and I just don't know how in the first place they have been created (look closely to code - especially line (if (not (member pp pplst)) (setq pplst (cons pp pplst)))...
Any help on these 2 issues will be very appreciated... So here is my code :

(defun nearest ( pt lst / d1 d2 p1 p2 )
  (setq lst (vl-remove pt lst))
  (setq d1 (distance pt (car lst))
        p1 (car lst)
  )
  (foreach p2 (cdr lst)
    (if (> d1 (setq d2 (distance pt p2)))
      (setq d1 d2 p1 p2)
    )
  )
  p1
)
 
(defun mid ( p1 p2 )
  (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
 
(defun c:dense ( / ss n entpt pt ptlst pttlst pp pplst p2 ptt loop )
  (setq ss (ssget '((0 . "POINT"))))
  (vl-cmdf "_.osnap" "off")
  (repeat (setq n (sslength ss))
    (setq entpt (ssname ss (setq n (1- n))))
    (setq pt (cdr (assoc 10 (entget entpt))))
    (setq ptlst (cons pt ptlst))
  )
  (setq pttlst ptlst)
  (foreach pt pttlst
    (setq ptlst pttlst)
    (setq ptt nil)
    (setq loop T)
    (while loop
      (if ptt (setq ptlst (vl-remove ptt ptlst)))
      (if (not (null (vl-remove pt ptlst)))
        (progn
          (setq p2 (nearest pt ptlst))
          (setq pp (mid pt p2))
          (if (not (member pp pplst)) (setq pplst (cons pp pplst)))
          (setq ptt pt)
          (setq pt p2)
        )
        (setq loop nil)
      )
    )
  )
  (foreach pt pplst
    (entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 pt)))
  )
  (princ)
)

Thanks for any reply, sincerely M.R.

[marko_ribar]

I've found out what was problem with overlapping - it was OSNAP...

So I added :

(vl-cmdf "_.osnap" "off")

So now remains issue ab speed...

M.R. (Above code updated - added (vl-cmdf "_.osnap" "off"))

[MSasu]

A good programming practice call to restore user’s environment after you changed it:

 (setq userOsnap (getvar "OSMODE"))
  (setvar "OSMODE" 0)
   
  ;;; processing
   
  (setvar "OSMODE" userOsnap)

[marko_ribar]

I've checked now with 5 points at start and repeated routine 4-5 times... It creates again overlapping points, so it isn't OSNAP the problem... Still there is issue of overlapping...

M.R.

[pBe]

Try

(if (not (ssget "_C" pp pp))
(entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 pp)))
              )

and remove the creation of pplst and entaking the point entity on the fly rather than from a list.

or even (not (nentselp pp)) ;<-- not so sure if it gives the same result though.. pickbox may be a factor in both.. maybe.. i'm not sure. my notebook is not powerful enough to test 1000 points..

[marko_ribar]

pBe, your method seems to work... Thank you very much... Now only issue is is there better alternative then cycling through each point to gain a few new points that are between 2 near points... With one cycle I have almost correct result, I just don't know how to gain remaining points without these repetitions for each point... Now code looks like this :

(defun nearest ( pt lst / d1 d2 p1 p2 )
  (setq lst (vl-remove pt lst))
  (setq d1 (distance pt (car lst))
        p1 (car lst)
  )
  (foreach p2 (cdr lst)
    (if (> d1 (setq d2 (distance pt p2)))
      (setq d1 d2 p1 p2)
    )
  )
  p1
)
 
(defun mid ( p1 p2 )
  (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
 
(defun c:dense ( / ss n entpt pt ptlst pttlst pp p2 ptt loop )
  (setq ss (ssget '((0 . "POINT"))))
  (vl-cmdf "_.osnap" "off")
  (repeat (setq n (sslength ss))
    (setq entpt (ssname ss (setq n (1- n))))
    (setq pt (cdr (assoc 10 (entget entpt))))
    (setq ptlst (cons pt ptlst))
  )
  (setq pttlst ptlst)
  (foreach pt pttlst
    (setq ptlst pttlst)
    (setq ptt nil)
    (setq loop T)
    (while loop
      (if ptt (setq ptlst (vl-remove ptt ptlst)))
      (if (not (null (vl-remove pt ptlst)))
        (progn
          (setq p2 (nearest pt ptlst))
          (setq pp (mid pt p2))
          (if (not (ssget "_C" pp pp)) 
            (entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 pp)))
          )
          (setq ptt pt)
          (setq pt p2)
        )
        (setq loop nil)
      )
    )
  )
  (princ)
)

pBe, thanks again for your reply and solving overlapping problem...
Regards, M.R.

[marko_ribar]

And here is streight forward solution from first to last point derivation in single loop...

(defun mid ( p1 p2 )
  (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
(defun c:dense ( / ss n entpt ptlst pt pp p2 )
  (setq ss (ssget "_X" '((0 . "POINT"))))
  (vl-cmdf "_.osnap" "off")
  (repeat (setq n (sslength ss))
    (setq entpt (ssname ss (setq n (1- n))))
    (setq pt (cdr (assoc 10 (entget entpt))))
    (setq ptlst (cons pt ptlst))
  )
  (setq ptlst (reverse ptlst))
  (while ptlst
    (setq pt (car ptlst))
    (if (cadr ptlst) (setq p2 (cadr ptlst)) (setq p2 nil))
    (if p2
      (progn
        (entdel (ssname (ssget "_C" pt pt) 0))
        (entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 pt)))
        (setq pp (mid pt p2))
        (entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 pp)))
      )
      (progn
        (entdel (ssname (ssget "_C" pt pt) 0))
        (entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 pt)))
      )         
    )
    (setq ptlst (cdr ptlst))
  )
  (princ)
)

M.R.

[BIGAL]

I can appreciate what you are doing but really the bottom line is how is the original survey data being captured adding extra points may not improve the model, we work the other way and ask our surveyors to change their technique, a good example is a existing road being surveyed, getting the points roughly square across yields a far better model than randomly walking the individual lines that make a road also when breaklines are added they are in true direction.

If you have a perfect grid survey no extra point will make it any better only reducing grid size will improve. The facets will not change.

Last word yes we will on occasions add some pts to individual lines to improve the mesh not a global add.

[pBe]

pBe, thanks again for your reply and solving overlapping problem...
Regards, M.R.

You are welcome M.R.

On your latest post, I cant say for sure I understand what its supposed to do. Cant give any advice or suggestions really.

Keep on coding
Cheers

[marko_ribar]

I struggled for a while until I didn't figured out whats the catch (seen triangulate.lsp - DTM function)... The catch was to check for every 3 points circumcircle against rest of points and find those 3 for witch no other rest points are inside circumcircle... My version of DTM is I guess preciser than DTM, but it's so much slower, I strongly suggest to use DTM.vlx... So here is my version (all before posts refer to this triangulation witch I finally got wright)...

(defun averpttriang (triangle)
  (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) (car triangle) (cadr triangle) (caddr triangle))
)

(defun unique (lst)
  (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))
)

(defun uniquetriangles (triangles / lst assoctriangles uniquetriangs)
  (foreach triangle triangles
    (setq lst (cons (averpttriang triangle) lst))
  )
  (setq lst (unique lst))
  (foreach triangle triangles
    (setq assoctriangles (cons (cons (averpttriang triangle) triangle) assoctriangles))
  )
  (foreach averpt lst
    (setq uniquetriangs (cons (cdr (assoc averpt assoctriangles)) uniquetriangs))
  )
  uniquetriangs
)

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

(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad)
  (setq pp1 (list (car p1) (cadr p1)))
  (setq pp2 (list (car p2) (cadr p2)))
  (setq pp3 (list (car p3) (cadr p3)))
  (setq mp1p2 (mid pp1 pp2))
  (setq mp2p3 (mid pp2 pp3))
  (setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0))
  (setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0))
  (setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil))
  (setq rad (distance cen p1))
  (list cen rad)
)

(defun ptinsidecir (pt circle)
  (setq pt (list (car pt) (cadr pt)))
  (> (cadr circle) (distance (car circle) pt))
)

(defun c:triangulate ( / msp ss n pt ptlst pttlst p1 p2 p3 circle tst lst triangles) (vl-load-com)
  (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (setq ss (ssget '((0 . "POINT"))))
  (repeat (setq n (sslength ss))
    (setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))
    (setq ptlst (cons pt ptlst))
  )
  (setq pttlst ptlst)
  (while (> (length ptlst) 2)
    (setq p1 (car ptlst))
    (foreach p2 (cdr ptlst)
      (foreach p3 (vl-remove p2 (cdr ptlst))
        (setq circle (circumtriang p1 p2 p3))
        (foreach pp (vl-remove p3 (vl-remove p2 (vl-remove p1 pttlst)))
          (if (not (ptinsidecir pp circle)) (setq tst (cons T tst)) (setq tst (cons nil tst)))
        )
        (if (eval (cons 'and tst)) (setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst)))
        (if lst (setq triangles (cons lst triangles)))
        (setq lst nil)
        (setq tst nil)
        (setq ptlst (vl-remove p1 ptlst))
        (setq ptlst (vl-remove p2 ptlst))
        (setq ptlst (vl-remove p3 ptlst))
        (setq ptlst (cons p3 ptlst))
        (setq ptlst (cons p2 ptlst))
      )
    )
  )
  (foreach triangle (uniquetriangles triangles)
    (vla-add3dface msp (vlax-3d-point (car triangle)) (vlax-3d-point (cadr triangle)) (vlax-3d-point (caddr triangle)) (vlax-3d-point (caddr triangle)))
  )    
  (princ)
)

BIGAL, you're wright ab interpolation of points... It's totally unnecessary as these 3dfaces represent just that...
pBe, thanks for your hidden suggestion not to suggest anything - it made me think and search for solution...
Keep coding
Regards, M.R.