(I need) LISP - binary tree join polilines a watershed

[Anonymous]

Hello All,

I need a lisp that creates the main stream of thalweg by polylines (basin - watershed) as the example below:

Someone to help?

[ActivistInvestor]

---

@Anonymous wrote:

I hate to say it after so much unpaid effort on your part, but providing these kinds of solutions is exactly what is turning this newsgroup into a forum for moochers rather than for programmers.  Here are a few links of interest:

Rush - Something For Nothing

People want something for nothing

---

I fully agree. Make note of how many posters are on user accounts with only half-a-dozen-or-so posts.  So, they they can just create a new account each time they want to mooch without carrying around the reputation of one.

However, the host bears some responsibility in that, as it seems that there is the intention to support exploitation of those who seem to think reputation (number of kudos/solutions) are important.

[ActivistInvestor]

---

@marko_ribar wrote:

Here, I revised my code and it works... Slooow, but it works...

HTH., M.R.

Now it's your turn to mark solution, or give a kudo...

---

Where does it say that the problem is to find the longest path?  You can't claim to have solved a problem when you don't know what the problem is.

The solution requires analysis of the elevations of the polylines. The main thalweg is the one whose elevation is lower than all others leading into it. You start at the mouth of the river and follow it upstream. Each time you reach the end of a segment where two tributaries join, you have to analyze the elevations of each of the two upstream paths to determine which is at a lower elevation, and then follow that one to the next junction, and repeat.

Analyzing the elevation involves calculating the lengths of two joining paths to find the elevation at a common distance from where they join, and calculating the stream gradient for the path - you cannot use the elevation of each segment's start point because they are of different lengths. You have to find the elevation at a point on each segment that is equal in distance from the point where the segments join. 

The fact that you don't understand the problem is also what leads you to believe that a human can easily solve the problem by 'looking at it'. A human cannot solve the problem by looking at it, because the solution involves the elevations of the polylines (yes, the original sample posted by OP was 'flattened', making it useless for solving the problem).

The solution to the problem is a bit more complicated than most seem to think. It's not finding the longest path. That's not the problem.

[_gile]

---

@Anonymous wrote:

I hate to say it after so much unpaid effort on your part, but providing these kinds of solutions is exactly what is turning this newsgroup into a forum for moochers rather than for programmers.  Here are a few links of interest:

Rush - Something For Nothing

People want something for nothing

---

I agree, even though I know that I was able to participate in that.
Often providing a routine is also responding to a challenge and it is always a way to learn.
And, for my part, it is sometimes easier to write LISP or C # than English.

[trevor.bird.au · Accepted solution]

Hi Horisman,

Please find my approach to your problem below.

It will create a magenta 3D polyline along the determined path and grip select it.

I've included "Process polylines with Z value reset to 0.0" as an option, otherwise remark out the 2 lines that are resetting the Z value for StartPoint_list and EndPoint_list.

The results will be different with Z = 0.0.

It currently filters the selection set to open polylines on layer "Stream" with color 172 (based on your example drawing).

I hope this helps.

Regards,

Trevor

;;  Thalweg.lsp by Trevor Bird
;;
;;  2018-02-09

;;------------------------------------------------------------------------------
(defun c:thalweg
  (
    /

    3DPL_ename

    assoc_EndPoints
    assoc_list
    assoc_StartPoints

    color_int
    col_ActiveBlock
    Coordinates_list
    Coordinates_sa
    Coordinates_var

    DistAtParam
    dps_EndPoints
    dps_Lengths
    dps_Path
    dps_Paths
    dps_StartPoints
    dp_Longest
    dp_Path

    EndParam
    EndPoint_list

    flag_draw
    flag_while

    index
    index_longest

    length_list
    length_path
    list_lengths
    list_LWPL
    list_LWPLs
    list_ObjectIDs
    list_Points
    list_StartPaths
    LWPL_ename

    ObjectID
    obj_3DPolyline
    obj_AD
    obj_LWPL

    Param
    PointAtParam_list

    ssC
    ss_Filter
    ss_grip
    ss_LWPL
    StartParam
    StartPoint_list

    sv_cvport
    sv_dimzin
    TimerEnd
    TimerStart
    Timer_FractionOfDay
    Timer_Seconds
  )
  (setq obj_AD    (vlax-get-property (vlax-get-acad-object) 'ActiveDocument)
        sv_cvport (getvar 'CVPORT)
  );setq


  (if (= sv_cvport 1)
    (setq col_ActiveBlock (vlax-get-property obj_AD 'PaperSpace))
    (setq col_ActiveBlock (vlax-get-property obj_AD 'ModelSpace))
  );if (= sv_cvport 1)


  (setq ss_Filter
    '(
      (0 . "*POLYLINE")
      (-4 . "&=")
        (70 . 0)
      (8 . "Stream")
      (62 . 172)
    );'
  );setq

  (if (= sv_cvport 1)
    (setq ss_Filter (append ss_Filter (list (list 410 (getvar 'CTAB)))))
    (setq ss_Filter (append ss_Filter '((410 . "Model"))))
  );if (= sv_cvport 1)




  (setq ss_LWPL (ssget ss_Filter))

  (cond
    ( (not ss_LWPL)
      (princ "\nNo LWPOLYLINE objects selected.")
    );(not ss_LWPL)


    (ss_LWPL
      ;;  <!--  Start Timer.
      (setq TimerStart  (getvar 'DATE))
      ;;  -->


      (setq ssC             -1
            dps_StartPoints nil
            dps_EndPoints   nil
      );setq

      (repeat (sslength ss_LWPL)
        (setq LWPL_ename        (ssname ss_LWPL (setq ssC (1+ ssC)))
              obj_LWPL          (vlax-ename->vla-object LWPL_ename)
              ObjectID          (vlax-get-property obj_LWPL 'ObjectID)

              StartParam        (vlax-curve-getStartParam obj_LWPL)
              EndParam          (vlax-curve-getEndParam obj_LWPL)

              StartPoint_list   (vlax-curve-getPointAtParam obj_LWPL StartParam)
              EndPoint_list     (vlax-curve-getPointAtParam obj_LWPL EndParam)

              ;;  Process polylines with Z value reset to 0.0
              StartPoint_list   (list (car StartPoint_list) (cadr StartPoint_list) 0.0)
              EndPoint_list     (list (car EndPoint_list) (cadr EndPoint_list) 0.0)

              list_LWPLs        (append list_LWPLs (list (list ObjectID StartPoint_list EndPoint_list)))

              assoc_StartPoints (assoc StartPoint_list dps_StartPoints)
              assoc_EndPoints   (assoc EndPoint_list dps_EndPoints)
        );setq


        (cond
          ( (not assoc_StartPoints)
            (setq dps_StartPoints (append dps_StartPoints (list (list StartPoint_list (list ObjectID)))))
          );(not assoc_StartPoints)

          (assoc_StartPoints
            (setq list_ObjectIDs  (cadr assoc_StartPoints)
                  list_ObjectIDs  (append list_ObjectIDs (list ObjectID))
                  dps_StartPoints (subst (list StartPoint_list list_ObjectIDs) assoc_StartPoints dps_StartPoints)
            );setq
          );assoc_StartPoints
        );cond


        (cond
          ( (not assoc_EndPoints)
            (setq dps_EndPoints (append dps_EndPoints (list (list EndPoint_list (list ObjectID)))))
          );(not assoc_EndPoints)

          (assoc_EndPoints
            (setq list_ObjectIDs  (cadr assoc_EndPoints)
                  list_ObjectIDs  (append list_ObjectIDs (list ObjectID))
                  dps_EndPoints   (subst (list EndPoint_list list_ObjectIDs) assoc_EndPoints dps_EndPoints)
            );setq
          );assoc_EndPoints
        );cond


        (vlax-release-object obj_LWPL)
      );repeat (sslength ss_LWPL)




      (setq list_StartPaths (vl-remove-if (function (lambda (_list) (assoc (car _list) dps_EndPoints))) dps_StartPoints)
            dps_Paths       nil
      );setq

      (foreach fe::list_Start list_StartPaths
        (setq list_ObjectIDs  (cadr fe::list_Start)
              ObjectID        (car list_ObjectIDs)
              obj_LWPL        (vlax-invoke-method obj_AD 'ObjectIdToObject ObjectID)
              EndParam        (vlax-curve-getEndParam obj_LWPL)
              DistAtParam     (vlax-curve-getdistatparam obj_LWPL EndParam)
        );setq

        (vlax-release-object obj_LWPL)

        (setq dps_Path    (list (cons ObjectID DistAtParam))
              flag_while  T
        );setq


        (while flag_while
          (setq list_LWPL     (assoc ObjectID list_LWPLs)
                EndPoint_list (caddr list_LWPL)
                assoc_list    (assoc EndPoint_list dps_StartPoints)
          );setq

          (cond
            ( (not assoc_list)
              (setq dps_Paths   (append dps_Paths (list dps_Path))
                    dps_Path    nil
                    flag_while  nil
              );setq
            );(not assoc_list)

            (assoc_list
              (setq list_ObjectIDs  (cadr assoc_list)
                    ObjectID        (car list_ObjectIDs)
                    obj_LWPL        (vlax-invoke-method obj_AD 'ObjectIdToObject ObjectID)
                    EndParam        (vlax-curve-getEndParam obj_LWPL)
                    DistAtParam     (vlax-curve-getdistatparam obj_LWPL EndParam)
              );setq

              (vlax-release-object obj_LWPL)

              (setq dps_Path  (append dps_Path (list (cons ObjectID DistAtParam))))
            );assoc_list
          );cond
        );while flag_while
      );fe::list_Start




      ;;  <!--  Determine longest path.
      (setq dps_Lengths nil
            index       -1
      );setq

      (foreach fe::dps dps_Paths
        (setq length_path (apply '+ (mapcar 'cdr fe::dps))
              dps_Lengths (append dps_Lengths (list (cons length_path (setq index (1+ index)))))
        );setq
      );fe::dps


      ;;  Sort longest to shortest.
      (setq list_lengths  (mapcar 'car dps_Lengths)
            list_lengths  (vl-sort list_lengths '>)
            dps_Lengths   (mapcar '(lambda (_length) (assoc _length dps_Lengths)) list_lengths)
      );setq


      ;;  Longest path.
      (setq dp_Longest    (car dps_Lengths)
            index_Longest (cdr dp_Longest)
            dp_Path       (nth index_Longest dps_Paths)
      );setq
      ;;  -->




      (setq ss_grip (ssadd))




      ;;  <!--  Draw 3D polyline along longest path.
      (setq flag_draw T
;            flag_draw  nil
      );setq

      (if flag_draw
        (progn
          (setq list_ObjectIDs  (mapcar 'car dp_Path)
                list_Points     nil
          );setq

          (foreach fe::ObjectID list_ObjectIDs
            (setq obj_LWPL          (vlax-invoke-method obj_AD 'ObjectIdToObject fe::ObjectID)
                  StartParam        (vlax-curve-getStartParam obj_LWPL)
                  EndParam          (vlax-curve-getEndParam obj_LWPL)
                  Param             StartParam
                  Coordinates_list  nil
            );setq

            (repeat (1+ (fix EndParam))
              (setq PointAtParam_list (vlax-curve-getPointAtParam obj_LWPL Param)
                    Coordinates_list  (append Coordinates_list (list PointAtParam_list))
                    Param             (+ Param 1.0)
              );setq
            );repeat (1+ (fix EndParam))

            (if (not list_Points)
              (setq list_Points Coordinates_list)
              (setq list_Points (append list_Points (cdr Coordinates_list)))
            );if (not list_Points)

            (vlax-release-object obj_LWPL)
          );fe::ObjectID


          (setq Coordinates_list  (mapcar 'float (apply 'append list_Points))
                length_list       (length Coordinates_list)
                Coordinates_sa    (vlax-make-safearray vlax-vbDouble (cons 0 (1- length_list)))
          );setq

          (vlax-safearray-fill Coordinates_sa Coordinates_list)

          (setq Coordinates_var (vlax-make-variant Coordinates_sa (logior vlax-vbArray vlax-vbDouble))
                obj_3DPolyline  (vlax-invoke-method col_ActiveBlock 'Add3DPoly Coordinates_var)
                3DPL_ename    (vlax-vla-object->ename obj_3DPolyline)
          );setq

          (vlax-put-property obj_3DPolyline 'Color acMagenta)

          (vlax-release-object obj_3DPolyline)

          (ssadd 3DPL_ename ss_grip)

          ;;  Grip and select.
          (sssetfirst nil ss_grip)
        );progn
      );if flag_draw
      ;;  -->




      ;;  <!--
;|
      (setq ss_grip (ssadd))

      (foreach fe::dp dp_Path
        (setq ObjectID    (car fe::dp)
              obj_LWPL    (vlax-invoke-method obj_AD 'ObjectIdToObject ObjectID)
              LWPL_ename  (vlax-vla-object->ename obj_LWPL)
        );setq

        (vlax-release-object obj_LWPL)

        (ssadd LWPL_ename ss_grip)
      );fe::dp


      ;;  Grip and select.
      (sssetfirst nil ss_grip)
|;
      ;;  -->




      ;;  <!--  End Timer.
      (setq TimerEnd            (getvar 'DATE)
            Timer_FractionOfDay  (- TimerEnd TimerStart)
            Timer_Seconds        (* 86400.0 Timer_FractionOfDay)
            sv_dimzin            (getvar 'DIMZIN)
      );setq
      (setvar 'DIMZIN  1)
      (princ "\nTime to process: ")
      (princ (rtos Timer_Seconds 2 2))
      (princ " seconds.\n")
      (setvar 'DIMZIN  sv_dimzin)
      ;;  -->
    );ss_LWPL
  );cond


  (vlax-release-object col_ActiveBlock)


  (princ)
);c:thalweg




;;------------------------------------------------------------------------------
(princ "\nThalweg loaded. Start command with THALWEG.")
(princ)

[marko_ribar]

I don't agree with @ActivistInvestor... The way I imagined the problem was more general... My code is applicable for every curve type and it is not relevant if start-end points are drawn in correct direction... Also if I may add my code is also applicable for both 2D and 3D situations and the flow in 3D is IMHO not important... Important thing is finding longest trunk of tree and my code highlights those entities allowing user to apply JOIN command afterwards and create single 2D or 3D curve no matter which type it should be POLYLINE/SPLINE, etc... The only lack of my code is that it is slow, so it is not in some cases applicable, but it surely is one solution to the task OP asked for... And it is general solution, so IMHO it's better than particular one...

[lando7189]

20 seconds!  That is quite the maze solving algorithm, SonicSSV -- i have Dale Fugier's DOSLib utility and added the 'dos_getprogress' to it to have a visual aide on progress -- pretty cool.  Kudos to you, sir!

dos_getprogress code locations:

      (if dos_getprogress (dos_getprogress "Evaluating Segments" "Please wait..." (sslength ss_LWPL)))
      (repeat (sslength ss_LWPL)
        (if dos_getprogress (dos_getprogress -1))

      );repeat (sslength ss_LWPL)
      (if dos_getprogress (dos_getprogress T))

      (if dos_getprogress (dos_getprogress "Calculating Path" "Please wait..." (length list_StartPaths)))
      (foreach fe::list_Start list_StartPaths
        (if dos_getprogress (dos_getprogress -1))

      );fe::list_Start
      (if dos_getprogress (dos_getprogress T))

[marko_ribar]

Hi again...

In this my second revision, if you haven't figured that out yet, I decided to add choice to process only picked branch or iterate through all branches... Of course you have to be clairvoyant to pick correct branch, but then speed would be much better... Still of OP's DWG it is useless as it's very exhaustive drawing... Nevertheless here is my revision and yes I think that OP disappeared again when solution is to be marked (I mean whatever he chooses - the code by Trevor Bird is very fast and it's applicable for OP's task and DWG he provided)...

(defun c:processtree ( / treechain trunkconst processreverse c ti ch r rr treeentities outerbranches trunk trunks dmax d trunkmax ) ;;; variable sss is global

  (vl-load-com)

  (defun treechain ( c / sp ep rtn ) ;;; r is global
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (setq rtn (append (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep))))))
    (foreach e rtn
      (if (not (vl-position e r))
        (progn
          (setq r (cons e r))
          (if (not (eq e c))
            (treechain e)
          )
        )
      )
    )
  )

  (defun trunkconst ( c / sp ep rtn nextc ) ;;; r is global
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (cond
      ( (and (car r) (ssmemb (car r) (ssget "_C" sp sp)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep)))))
      )
      ( (and (car r) (ssmemb (car r) (ssget "_C" ep ep)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))))
      )
      ( t
        (setq rtn (append (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep))))))
      )
    )
    (setq nextc (car (vl-sort (vl-remove-if '(lambda ( x ) (or (vl-position x r) (vl-position x rr))) (vl-remove c rtn)) '(lambda ( a b ) (< (vlax-curve-getdistatparam a (vlax-curve-getendparam a)) (vlax-curve-getdistatparam b (vlax-curve-getendparam b)))))))
    (if (not (vl-position c r))
      (setq r (cons c r))
    )
    (if nextc
      (trunkconst nextc)
    )
  )

  (defun processreverse ( c / sp ep rtn nextc ) ;;; rr is global
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (cond
      ( (and (car rr) (ssmemb (car rr) (ssget "_C" sp sp)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep)))))
      )
      ( (and (car rr) (ssmemb (car rr) (ssget "_C" ep ep)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))))
      )
      ( t
        (setq rtn (append (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep))))))
      )
    )
    (setq nextc (car (vl-sort (vl-remove-if '(lambda ( x ) (or (vl-position x r) (vl-position x rr))) (vl-remove c rtn)) '(lambda ( a b ) (< (vlax-curve-getdistatparam a (vlax-curve-getendparam a)) (vlax-curve-getdistatparam b (vlax-curve-getendparam b)))))))
    (if (not (vl-position c rr))
      (setq rr (cons c rr))
    )
    (if (vl-position nextc (apply 'append trunks))
      (processreverse nextc)
    )
  )

  (alert "Set zoom of view such that complete tree of interest is visible on screen and only then apply routine...")
  (while (or (not (setq c (car (entsel "\nPick tree outer branch curve entity...")))) (if c (or (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartpoint (list c))) (and (> (sslength (ssget "_C" (vlax-curve-getstartpoint c) (vlax-curve-getstartpoint c))) 1) (> (sslength (ssget "_C" (vlax-curve-getendpoint c) (vlax-curve-getendpoint c))) 1)))))
    (prompt "\nMissed or picked wrong entity type or picked curve not tree outer branch entity...")
  )
  (initget "Yes No")
  (setq ch (getkword "\nProcess only picked branch (Yes) or iterate through all tree branches (No) [Yes/No] <Yes> : "))
  (if (null ch)
    (setq ch "Yes")
  )
  (setq ti (car (_vl-times)))
  (treechain c)
  (setq treeentities r)
  (setq r nil)
  (if (= ch "Yes")
    (progn
      (while (not (vl-every '(lambda ( x ) (vl-position x (apply 'append trunks))) treeentities))
        (trunkconst c)
        (setq trunk r)
        (setq trunks (cons trunk trunks))
        (processreverse (car trunk))
        (setq r nil)
      )
      (if (null dmax)
        (setq dmax 0.0)
      )
      (foreach trunk trunks
        (setq d (apply '+ (mapcar '(lambda ( x ) (vlax-curve-getdistatparam x (vlax-curve-getendparam x))) trunk)))
        (if (> d dmax)
          (setq dmax d trunkmax trunk)
        )
      )
    )
    (progn
      (setq outerbranches (vl-remove-if-not '(lambda ( x ) (or (= (sslength (ssget "_C" (vlax-curve-getstartpoint x) (vlax-curve-getstartpoint x))) 1) (= (sslength (ssget "_C" (vlax-curve-getendpoint x) (vlax-curve-getendpoint x))) 1))) treeentities))
      (foreach branch outerbranches
        (while (not (vl-every '(lambda ( x ) (vl-position x (apply 'append trunks))) treeentities))
          (trunkconst branch)
          (setq trunk r)
          (setq trunks (cons trunk trunks))
          (processreverse (car trunk))
          (setq r nil)
        )
        (if (null dmax)
          (setq dmax 0.0)
        )
        (foreach trunk trunks
          (setq d (apply '+ (mapcar '(lambda ( x ) (vlax-curve-getdistatparam x (vlax-curve-getendparam x))) trunk)))
          (if (> d dmax)
            (setq dmax d trunkmax trunk)
          )
        )
        (setq trunks nil rr nil)
      )
    )
  )
  (setq sss (ssadd))
  (foreach c trunkmax
    (ssadd c sss)
  )
  (prompt "\nHighlighted trunk of maximum length... Sel.set is stored in variable \"sss\". You can call it with (c:sss)...")
  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  (sssetfirst nil sss)
  (princ)
)

Regards, M.R.

[ActivistInvestor]

---

@marko_ribar wrote:

I don't agree with @ActivistInvestor... The way I imagined the problem was more general... My code is applicable for every curve type and it is not relevant if start-end points are drawn in correct direction... Also if I may add my code is also applicable for both 2D and 3D situations and the flow in 3D is IMHO not important... Important thing is finding longest trunk of tree and my code highlights those entities allowing user to apply JOIN command afterwards and create single 2D or 3D curve no matter which type it should be POLYLINE/SPLINE, etc... The only lack of my code is that it is slow, so it is not in some cases applicable, but it surely is one solution to the task OP asked for... And it is general solution, so IMHO it's better than particular one...

---

The problem is not finding longest trunk of tree.

[marko_ribar]

---

@ActivistInvestor wrote:

---

The problem is not finding longest trunk of tree.

Well if you know what the problem is all about, why don't you write a code and make yourself happier... I am sure OP and your boss would be happy also...

Of course that I am doing by my rules... You'll find that they aren't so wrong after all... And yes I am using my code for my own customization purposes, that's why my version is so general and not particular...

Thanks for your remark anyway...

---

[marko_ribar · Accepted solution]

Not 100% sure ab reliability, but I managed to speed my code slightly and according to my testings it's better now...

So here is my third revision :

(defun c:processtree ( / treechain trunkconst processreverse c ti ch r rr treeentities outerbranches trunk trunks dmax d trunkmax ) ;;; variable sss is global

  (vl-load-com)

  (defun treechain ( c / sp ep rtn ) ;;; r is global
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (setq rtn (append (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep))))))
    (foreach e rtn
      (if (not (vl-position e r))
        (progn
          (setq r (cons e r))
          (if (not (eq e c))
            (treechain e)
          )
        )
      )
    )
  )

  (defun trunkconst ( c / sp ep rtn nextc ) ;;; r is global
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (cond
      ( (and (car (vl-remove c r)) (ssmemb (car (vl-remove c r)) (ssget "_C" sp sp)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep)))))
      )
      ( (and (car (vl-remove c r)) (ssmemb (car (vl-remove c r)) (ssget "_C" ep ep)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))))
      )
      ( t
        (setq rtn (append (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep))))))
      )
    )
    (setq nextc (car (vl-sort (vl-remove-if '(lambda ( x ) (or (vl-position x r) (vl-position x rr))) (vl-remove c rtn)) '(lambda ( a b ) (< (vlax-curve-getdistatparam a (vlax-curve-getendparam a)) (vlax-curve-getdistatparam b (vlax-curve-getendparam b)))))))
    (if (not (vl-position c r))
      (setq r (cons c r))
    )
    (if nextc
      (trunkconst nextc)
    )
  )

  (defun processreverse ( c / sp ep rtn nextc ) ;;; rr is global
    (setq sp (vlax-curve-getstartpoint c))
    (setq ep (vlax-curve-getendpoint c))
    (cond
      ( (and (car (vl-remove c rr)) (ssmemb (car (vl-remove c rr)) (ssget "_C" sp sp)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep)))))
      )
      ( (and (car (vl-remove c rr)) (ssmemb (car (vl-remove c rr)) (ssget "_C" ep ep)))
        (setq rtn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))))
      )
      ( t
        (setq rtn (append (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" sp sp)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" ep ep))))))
      )
    )
    (setq nextc (car (vl-sort (vl-remove-if '(lambda ( x ) (or (vl-position x r) (vl-position x rr))) (vl-remove c rtn)) '(lambda ( a b ) (< (vlax-curve-getdistatparam a (vlax-curve-getendparam a)) (vlax-curve-getdistatparam b (vlax-curve-getendparam b)))))))
    (if (not (vl-position c rr))
      (setq rr (cons c rr))
    )
    (if (vl-position nextc (apply 'append trunks))
      (processreverse nextc)
    )
  )

  (alert "Set zoom of view such that complete tree of interest is visible on screen and only then apply routine...")
  (while (or (not (setq c (car (entsel "\nPick tree outer branch curve entity...")))) (if c (or (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartpoint (list c))) (and (> (sslength (ssget "_C" (vlax-curve-getstartpoint c) (vlax-curve-getstartpoint c))) 1) (> (sslength (ssget "_C" (vlax-curve-getendpoint c) (vlax-curve-getendpoint c))) 1)))))
    (prompt "\nMissed or picked wrong entity type or picked curve not tree outer branch entity...")
  )
  (initget "Yes No")
  (setq ch (getkword "\nProcess only picked branch (Yes) or iterate through all tree branches (No) [Yes/No] <Yes> : "))
  (if (null ch)
    (setq ch "Yes")
  )
  (setq ti (car (_vl-times)))
  (treechain c)
  (setq treeentities r)
  (setq r nil)
  (if (= ch "Yes")
    (progn
      (trunkconst c)
      (setq trunk r)
      (setq trunks (cons trunk trunks))
      (while (and r (not (vl-every '(lambda ( x ) (vl-position x (apply 'append trunks))) treeentities)))
        (processreverse (car trunk))
        (setq r (cdr (member (car rr) trunk)))
        (if r
          (trunkconst (car r))
        )
        (setq trunk r)
        (setq trunks (cons trunk trunks))
      )
      (if (null dmax)
        (setq dmax 0.0)
      )
      (foreach trunk trunks
        (setq d (apply '+ (mapcar '(lambda ( x ) (vlax-curve-getdistatparam x (vlax-curve-getendparam x))) trunk)))
        (if (> d dmax)
          (setq dmax d trunkmax trunk)
        )
      )
    )
    (progn
      (setq outerbranches (vl-remove-if-not '(lambda ( x ) (or (= (sslength (ssget "_C" (vlax-curve-getstartpoint x) (vlax-curve-getstartpoint x))) 1) (= (sslength (ssget "_C" (vlax-curve-getendpoint x) (vlax-curve-getendpoint x))) 1))) treeentities))
      (foreach branch outerbranches
        (trunkconst branch)
        (setq trunk r)
        (setq trunks (cons trunk trunks))
        (while (and r (not (vl-every '(lambda ( x ) (vl-position x (apply 'append trunks))) treeentities)))
          (processreverse (car trunk))
          (setq r (cdr (member (car rr) trunk)))
          (if r
            (trunkconst (car r))
          )
          (setq trunk r)
          (setq trunks (cons trunk trunks))
        )
        (if (null dmax)
          (setq dmax 0.0)
        )
        (foreach trunk trunks
          (setq d (apply '+ (mapcar '(lambda ( x ) (vlax-curve-getdistatparam x (vlax-curve-getendparam x))) trunk)))
          (if (> d dmax)
            (setq dmax d trunkmax trunk)
          )
        )
        (setq trunks nil rr nil r nil)
      )
    )
  )
  (setq sss (ssadd))
  (foreach c trunkmax
    (ssadd c sss)
  )
  (prompt "\nHighlighted trunk of maximum length... Sel.set is stored in variable \"sss\". You can call it with (c:sss)...")
  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  (sssetfirst nil sss)
  (princ)
)

HTH., M.R.

P.S. I haven't given up from my vision of solution...

[ActivistInvestor]

---

@marko_ribar wrote:

---

Well if you know what the problem is all about, why don't you write a code and make yourself happier... I am sure OP and your boss would be happy also...

---

Because I don't provide software development services for free ?

[john.uhden]

It strikes me that if the main channel were continuous, then the only polyline that would neither begin nor end at an intersection with another polyline would be the main channel.  But I guess that would mean that someone or the source program that created the polylines knew the answer in the first place.

If the main channel polyline stopped (upstream) at a junction with 2 or more tributary polylines, then the main channel could be interpreted as continuing up any of the tributaries.  So I guess we would have to build a list of possibles and delete them from the list if they don't make it to the boundary.  Then again, if the boundary is the watershed, it is most likely that neither the main channel nor any of the tributaries will make it all the way to the watershed boundary as there would most always be an area of sheet flow upstream.  One S.F. of drainage area doth not a stream make.

Thanks, guys.  You will have ruined my nap time.

[john.uhden]

Votre anglais c'est magnifique (or something like that).

[john.uhden]

Maybe one can just surmise that any polyline that has no point of confluence with another is a main channel.

"Ellie, the river, THE RIVER!"