[TZFLeader]

Здравствуйте. Имеется ось дороги, имеется съёмка кромки покрытия дороги (на чертеже жёлтая известная линия) с разным отступом от оси (20 и 30 метров) в начале и в конце трассы. Помогите, пожалуйста, достроить кромку дороги (на чертеже пунктирная линия) между этими известными линиями. Спасибо

----- добавлено через ~35 мин. -----
Решение нашёл.

Код:

[Выделить все]

 (vl-load-com)
(defun q_dir (p1 p2 p3 / v1 v2 v_or)
  (setq
    v1 (mapcar '- p2 p1)
    v2 (mapcar '- p1 p3)
    v_or
    (apply '(lambda (x1 y1 z1 x2 y2 z2) (- (* x1 y2) (* y1 x2)))
      (append v1 v2)
    )
  )
)
(defun c:Progressive_Offset ( / js AcDoc Space th_start th_end ent obj param_curve perim_curve nb_vtx lst_pt lst_pl1 lst_pl2 deriv-1 det-or n-1 p_start p_end deriv dir_tg bulg rad p_cen alpha alpha_inc nw_pt op1 op2 d tmp_pt1 tmp_pt2 nw_pl)
  (princ "\nSelect polyline: ")
  (while (not (setq js (ssget "_+.:E:S" '((0 . "*POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 126) (-4 . "NOT>")))))
    (princ "\nNo valid objects or empty selection!")
  )
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
  )
  (vla-startundomark AcDoc)
  (setq
    ent (ssname js 0)
    obj (vlax-ename->vla-object ent)
    param_curve (vlax-curve-getEndParam obj)
    perim_curve (vlax-curve-getDistAtParam obj param_curve)
    nb_vtx -1
    lst_pt nil
    lst_pl1 nil
    lst_pl2 nil
    deriv-1 nil
    det_or nil
    n-1 nil
  )
  (initget 5)
  (setq th_start (getdist (trans (vlax-curve-getPointAtParam obj 0) 0 1) "\nStarting Half Width: "))
  (initget 4)
  (setq th_end (getdist (trans (vlax-curve-getPointAtParam obj param_curve) 0 1) (strcat "\nEnd Half Width <" (rtos (* 0.5 (/ (/ th_start perim_curve) (/ (1+ (sqrt 5)) 2)))) ">: ")))
  (if (not th_end) (setq th_end (* 0.5 (/ (/ th_start perim_curve) (/ (1+ (sqrt 5)) 2)))))
  (repeat (1+ (fix param_curve))
    (setq
      nb_vtx (1+ nb_vtx)
      p_start (vlax-curve-getPointAtParam obj nb_vtx)
      p_end (vlax-curve-getPointAtParam obj (1+ nb_vtx))
      deriv (vlax-curve-getFirstDeriv obj nb_vtx)
      deriv-1
      (if (not deriv-1)
        (if (and (zerop nb_vtx) (eq (vla-Get-Closed obj) ':vlax-true))
          (vlax-curve-getFirstDeriv obj (fix param_curve))
          deriv
        )
        (if (and (eq nb_vtx (fix param_curve)) (eq (vla-Get-Closed obj) ':vlax-true))
          (vlax-curve-getFirstDeriv obj 0)
          deriv-1
        )
      )
      lst_pt
      (cons
        (list
          p_start
          (setq dir_tg
            (* 0.5
              (+
                (atan (cadr deriv) (car deriv))
                (atan (cadr deriv-1) (car deriv-1))
              )
            )
          )
          (- (atan (cadr deriv) (car deriv)) dir_tg)
          (if (and (eq nb_vtx (fix param_curve)) (eq (vla-Get-Closed obj) ':vlax-true))
            th_end
            (+ th_start (* (/ (- th_end th_start) perim_curve) (vlax-curve-getDistAtParam obj nb_vtx)))
          )
        )
        lst_pt
      )
      deriv-1 deriv
    )
    (cond
      ((and p_end (not (zerop (setq bulg (vla-GetBulge obj nb_vtx)))))
        (setq
          rad (/ (distance (trans p_start 0 ent) (trans p_end 0 ent)) (sin (* 2.0 (atan bulg))) 2.0)
          p_cen
          (trans
            (polar
              (trans p_start 0 ent)
              (+ (angle (trans p_start 0 ent) (trans p_end 0 ent)) (- (* 0.5 pi) (* 2.0 (atan bulg))))
              rad
            )
          ent 0
          )
          alpha (angle (trans p_cen 0 ent) (if (< bulg 0.0) (trans p_end 0 ent) (trans p_start 0 ent)))
          alpha_inc (angle (trans p_cen 0 ent) (trans p_start 0 ent))
        )
        (repeat (fix (/ (rem (- (+ (* 2.0 pi) (angle (trans p_cen 0 ent) (if (< bulg 0.0) (trans p_start 0 ent) (trans p_end 0 ent)))) alpha) (* 2.0 pi)) (/ pi (/ 100.0 pi))))
          (setq
            alpha_inc (if (< bulg 0.0) (- alpha_inc (/ pi (/ 100.0 pi))) (+ alpha_inc (/ pi (/ 100.0 pi))))
            nw_pt (trans (polar (trans p_cen 0 ent) alpha_inc (abs rad)) ent 0)
            deriv (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj nw_pt))
            lst_pt
            (cons
              (list
                nw_pt
                (atan (cadr deriv) (car deriv))
                0.0
                (+ th_start (* (/ (- th_end th_start) perim_curve) (vlax-curve-getDistAtPoint obj nw_pt)))
              )
              lst_pt
            )
            deriv-1 deriv
          )
        )
      )
    )
  )
  (setq
    det_or (q_dir (caar lst_pt) (caadr lst_pt) (trans (polar (caar lst_pt) (+ (cadar lst_pt) (* 0.5 pi)) (caddar lst_pt)) 0 ent))
    op1 (if (> det_or 0.0) '+ '-)
    op2 (if (> det_or 0.0) '- '+)
  )
  (foreach n lst_pt
    (setq d (/ (cadddr n) (cos (caddr n))))
    (if n-1
      (setq
        det_or (q_dir (car n) n-1 (polar (car n) (+ (cadr n) (* 0.5 pi)) d))
        op1 (if (> det_or 0.0) '+ '-)
        op2 (if (> det_or 0.0) '- '+)
        tmp_pt1 (trans (polar (car n) ((eval op1) (cadr n) (* 0.5 pi)) d) 0 ent)
        tmp_pt2 (trans (polar (car n) ((eval op2) (cadr n) (* 0.5 pi)) d) 0 ent)
        lst_pl1 (cons tmp_pt1 lst_pl1)
        lst_pl2 (cons tmp_pt2 lst_pl2)
        n-1 (car n)
      )
      (setq
        tmp_pt1 (trans (polar (car n) ((eval op1) (cadr n) (* 0.5 pi)) d) 0 ent)
        tmp_pt2 (trans (polar (car n) ((eval op2) (cadr n) (* 0.5 pi)) d) 0 ent)
        lst_pl1 (cons tmp_pt1 lst_pl1)
        lst_pl2 (cons tmp_pt2 lst_pl2)
        n-1 (car n)
      )
    )
  )
  (setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car lst_pl1) (mapcar 'cadr lst_pl1)))))
  (if (eq (vla-Get-Closed obj) ':vlax-true) (vla-put-Closed nw_pl 1))
  (vla-put-Normal nw_pl (vla-get-Normal obj))
  (vla-put-Elevation nw_pl (vla-get-Elevation obj))
  (setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car lst_pl2) (mapcar 'cadr lst_pl2)))))
  (if (eq (vla-Get-Closed obj) ':vlax-true) (vla-put-Closed nw_pl 1))
  (vla-put-Normal nw_pl (vla-get-Normal obj))
  (vla-put-Elevation nw_pl (vla-get-Elevation obj))
  (vla-endundomark AcDoc)
  (prin1)
)

Всем спасибо