Lisp vẽ mái taluy

;;;=======================================
;;; TLF draw fill
;;; TLC draw cut
;;; TLSET Set global variable for double tl
;;; SETTL  set for single tl
;;; TL draw single TL
;;; USES WORLD COORDINATE SYSTEM
(setq distmin 1.0)
(setq distmax 3.5)
(setq segmin 1.0)
;====================================================================
(setq distmin 0.5) ; min distance between segment
(setq distmax 1.5) ; max distance between segment
(setq segmin 0.25) ; khoang cach noi suy khi ve ta luy
(setq kctl 1) ; distance between line
(setq dngan 1) ; Length of short line
(setq ddai 2) ; Length of long line
(setq chieutl 1)
(setq chieutl 1)
;=================================================================
;============== Doc toa do duong polyline =====
(defun readpl (pl / e l  ds p)
  (if (not (equal pl etcam)) (progn
    (setq ds '())
    (setq e (entget pl))
    (setq l (cdr (assoc 0 e)))
    (if (= l "lwPOLYLINE")
        (progn
          (setq pl (entnext pl))
          (setq e (entget pl))
          (setq l (cdr (assoc 0 e)))
          (while  (= l "VERTEX")
                (setq p (cdr (assoc 10 e)))
                (setq ds (cons p ds))
                (setq pl (entnext pl))
                (setq e (entget pl))
                (setq l (cdr (assoc 0 e)))
          )
        )
    )
    (if (= l "LINE")
        (setq ds (list
                    (cdr(assoc 11 e))
                    (cdr(assoc 10 e))
                )
        ) 
    )
    (setq ds (reverse ds))
    (if (= l "LWPOLYLINE")
      (setq ds (xddstd pl)  )
    )
 ))
    (setq ds ds)
)
;;;--- Setup for taluy --
(defun c:tlset (/ mi ma mg)
    (setq mi (getreal (strcat "Min Distance [" (rtos distmin 2 2) "]: " ) ))
    (if mi (setq distmin mi))
    (setq ma (getreal (strcat "Max Distance [" (rtos distmax 2 2) "]: " ) ))
    (if ma (setq distmax ma))
    (setq mg (getreal (strcat "Segmin  [" (rtos segmin 2 2) "]: " ) ))
    (if mg (setq segmin mg))
)
;;;---- lay ds td cua pline --
(defun xddstd ( pl / e ds len td1 p)
  (setq e (entget pl))
  (if (=(cdr (assoc 0 e) ) "LWPOLYLINE")
    (progn
        (setq len (length e))
        (setq td1 0)
        (repeat len
          (setq p (nth td1 e))
          (setq td1 (+ 1 td1))
          (if (= (car p) 10)
              (setq ds (cons (cdr p) ds )) 
          )
        )
    )
  )
(setq ds (reverse ds))
)
;;;--- Xac dinh doan gan nhat --
(defun xdmin(dstd p / p1 p2 len td2 d dmin k)
    (setq len (length dstd))
    (setq td2 0)
    (setq k td2)
    (setq dmin (distance (car dstd) p))
    (repeat (-  len 1)
      (setq p1 (nth td2 dstd))
      (setq td2 (+ td2 1))   
      (setq p2 (nth td2 dstd))
      (setq d (distance p1 p))
      (if (< d dmin)
          (progn
            (setq  dmin d)
            (setq k (- td2 1))
          )
      )
      (setq d (distance p2 p))
      (if (< d dmin)
          (progn
            (setq  dmin d)
            (setq k td2)
          )
      )
    )
(if (> k 0)
  (setq td2 (- k 1))
  (setq td2 0)
)
(setq p1 (nth td2 dstd))
(setq td2 (+ td2 1))   
(setq p2 (nth td2 dstd))
(list p1 p2)
)
;----- Xac dinh chieu p - pl
(defun chieu ( p / ds a1 a2 a c)
  ;(setq ds (xddstd pl))
  (setq ds ds111 )
  (setq ds111 ds)
  (if ds (progn
    (setq ds (xdmin ds p))
    (setq a1 (angle (car ds) (cadr ds) ))
    (setq a2 (angle (car ds) p ))
    (setq a (- a2 a1))
    ;(if (and (> a 0) (< a pi))
    (if  (> (sin a)  0)
        (setq c 1)
        (setq c -1)
    )
  ))
(setq c c)
)
;;;- ke mot duong thang  ---
(defun mkl (p1 p2 / e)
  (setq p1 (cons 10 p1)  )
  (setq p2 (cons 11 p2)  )
  (setq e (list
      '(0 . "LINE")
      p1
      p2
  )) 
  (entmake e)
)
;=================================
;;;============================================================
;;; Ve duong taluy
(defun tlx (/ dsp pl  p1 p2 ag  pc pl1 td3 l sumdist dist pv overdist cl el pchieu)
  (setq ds111 nil)
  (setq pl (entsel "First Polyline"))
  (redraw (car pl) 3)
  (setq pl1 (entsel "\n Second Polyline"))
  (redraw (car pl1) 3)
  ;(setq pchieu (getpoint "\nside of Polyline"))
  (setq pchieu (cadr pl1))
  (redraw (car pl) 3)
  (redraw (car pl1) 3)
  (if (and pl pl1) (progn
    ;;;---------------------
    ;(setq dsp (xddstd (car pl)))
    (setq ds111 (dspm pl segmin))
    (setq dsp ds111)
    (setq dsxoa (ssadd))
    (setq pc (cadr pl1))
    (setq pl1 (car pl1))
    ;------------------------
    (setq chieutl (chieu  pchieu))
    (setq td3 0)
    (setq l (-(length dsp)1))
    (setq sumdist 0)
    ;--------
    (while (< td3 l)
        (progn
          (setq distover (- sumdist))
          (setq p1  (nth td3 dsp))
          (setq td3 (+ td3 1))
          (setq p2  (nth td3 dsp))
          (setq sumdist (distance p1 p2))
          (setq pv (angle p1 p2))
          (setq  p1 (polar p1 pv distover) );jjjj
          (setq sumdist (- sumdist distover))
          (while (> sumdist 0)
              (setq dist (veline p1 pv chieutl pl1))
              (if (or (not dist) (< dist distmin))
                  (setq dist distmin)
              )
              (if (> dist distmax)
                  (setq dist distmax)
              )
              (setq  p1 (polar p1 pv dist) )
              (setq sumdist (- sumdist dist))
          )
        ) 
    )
    ;-------
  )) 
  (setq dscuoi dsxoa)
)
;----- Xoa cuoi ---
(defun c:utl ()
  (command "ERASE" dsxoa "")
)
;---- Ve 1 duong va keo dai -----
(defun veline ( p1 agd chieutl pl1 / ag vd kq dist ec em)
                (setq ag (+ agd (*(/ pi 2)chieutl)) ) 
                (setq p2 (polar p1 ag segmin))
                (mkl p1 p2)
                ;------------------
                (setq vd (entlast))
                (REDRAW VD 3)
                (setq ec (entget vd))
                (setq vd (list vd p2))
                (command "EXTEND" pl1 "" vd ""  )
                (setq vd (car vd))
                (setq em (entget vd))
                (if (equal ec em)
                    (entdel vd)
                    (progn
                        (setq p1 (cdr (assoc 10 em)))
                        (setq p2 (cdr (assoc 11 em)))
                        (setq kq (/(mykc p1 p2)2))
                        (setq dsxoa (ssadd vd dsxoa))
                    )
                ) 
(setq kq kq)
)
;---- doi thanh doan dap ------
(defun nganf (vd / e p1 p2 d)
  (if vd (progn
      (setq e (entget vd))
      (setq p1 (cdr (assoc 10  e ) ))
      (setq p2 (cdr (assoc 11  e ) ))
      (setq d (/(mykc p1 p2)2))
      (if (> d distmax)
        (setq d distmax)
      )
      (setq pv (angle p1 p2))
      (setq p2 (polar p1 pv d))
      (setq e (subst (cons 11 p2) (assoc 11 e) e )) 
      (entmod e)
      (entupd vd)
  ))
)
;---- ve ta luy dao --
(defun c:tlc ( / l td4 e)
    (command "UNDO" "group")
    (setq dscuoi nil)
    (command "LAYER" "m" "TLCUT" "")
    (tlx)
    (if dscuoi
      (progn
          (setq l (sslength dscuoi))
          (setq td4 0)
          (repeat (+(/ l 2)1)
            (setq e (ssname dscuoi td4))
            (setq td4 (+ td4 2))
            (nganc e)
          ) 
      ) 
    )
    (command "UNDO" "end")
)
;---- doi thanh doan dao ------
(defun nganc (vd / e p1 p2 d)
  (if vd (progn
      (setq e (entget vd))
      (setq p1 (cdr (assoc 10  e ) ))
      (setq p2 (cdr (assoc 11  e ) ))
      (setq d (/(mykc p1 p2)2))
      (if (> d distmax)
        (setq d  distmax)
      )
      (setq pv (angle p2 p1))
      (setq p1 (polar p2 pv d))
      (setq e (subst (cons 10 p1) (assoc 10 e) e )) 
      (entmod e)
      (entupd vd)
  ))
)
;---- ve ta luy dap --
(defun c:tlf ( / l td5 e)
    (command "UNDO" "group")
    (command "LAYER" "m" "TLFIL" "")
    (setq dscuoi nil)
    (tlx)
    (if dscuoi
      (progn
          (setq l (sslength dscuoi))
          (setq td5 0)
          (repeat (+(/ l 2)1)
            (setq e (ssname dscuoi td5))
            (setq td5 (+ td5 2))
            (nganf e)
          ) 
      ) 
    )
    (command "UNDO" "end")
)
;-- tinh kc 2 diem ---
(defun mykc (p1 p2 / x1 y1 x2 y2 dx dy)
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))
  (setq dx (- x2 x1))
  (setq dy (- y2 y1))
  (sqrt (+(* dx dx) (* dy dy)))
)
;--- Lay danh sach diem bang mesure ---
(defun dspm (e segmin /  el p dskq sst l)
  ;(setq e (entsel))
  (setq el (entlast))
  (setq sst (ssadd))
  (command "MEASURE" e segmin)
  (setq el (entnext el))
  (while el
      (setq p (cdr (assoc 10  (entget el) ) ))
      (setq l (cdr (assoc 0  (entget el) ) ))
      (if (and (= l "POINT") p)
        (setq dskq (cons p dskq))
      )
      (setq sst (ssadd el sst))
      (setq el (entnext el))
  )

(setq dskq (reverse dskq))
)
;;;=======================================
TL - Ve taluy
;;;=======================================
;;; Ve ta luy
;;;-------------------------
;;; Ve duong taluy
(defun c:tl (/ pl  el e0 es p1 p2 ag ss ek cl  pc)
  (command "UNDO" "group")
  (command "LAYER" "m" "slopes" "")
  (setq pl (entsel))
  (if pl (progn
    (setq pc (getpoint "Side of TL"))
    (setq chieutl (chieupl (car pl) pc ))
    (setq el (entlast))
    (command "MEASURE" pl kctl)
    (setq ek (entlast))
    (setq ss (ssadd))
    ;--------
    (while (and el
                (not (equal el ek) )
            )
      (setq el (entnext el))
      (if el (setq ss (ssadd el ss)) )
      (if el 
            (setq es (entnext el))
      )
      (if (and el es (= (cdr (assoc 0 (entget el))) "POINT") )
        (progn
          (setq p1 (cdr(assoc 10 (entget el)))    )
          (setq p2 (cdr(assoc 10 (entget es)))    )
          ;-------------
          (if (not(equal el ek))(progn
                (setq ag (angle p1 p2))
                (setq ag (+ ag (*(/ pi 2)chieutl)) ) 
          ))
          (if cl
              (setq p2 (polar p1 ag dngan))
              (setq p2 (polar p1 ag ddai))
          )
          (if cl
              (setq cl nil)
              (setq cl 1)
          )
          ;(command "LINE" p1 p2 "")
          (mkl p1 p2)
          ;---------------------
        ) 
      )
    )
    ;-------
   
  )) 
  (command "UNDO" "end")
)
;----------------
;----- Xac dinh chieu p - pl
(defun chieupl (pl p / ds a1 a2 a c)
  ;(setq ds (xddstd pl))
  (setq c 1)
  (setq ds (readpl pl))
  (if ds (progn
    (setq ds (xdmin ds p))

    (setq a1 (angle (car ds) (cadr ds) ))
    (setq a2 (angle (car ds) p ))
    (setq a (- a2 a1))
    (if (and (> a 0) (< a pi))
        (setq c 1)
        (setq c -1)
    )
  ))
(setq c c)
)

;;;;;;;;;;;;;;;
(defun c:settl (/ a1 a2 a3)
    (setq a1 (getstring (strcat "Distance between line " (rtos kctl 2 2) ": "  ) ))
    (setq a2 (getstring (strcat "\nLength of short line " (rtos dngan 2 2)": "  ) ))
    (setq a3 (getstring (strcat "\nLength of long line " (rtos ddai 2 2) ": " ) ))
    (if (/= a1 "")
      (setq kctl (atof a1))
    )
    (if (/= a2 "")
      (setq dngan (atof a2))
    )
    (if (/= a3 "")
      (setq ddai (atof a3))
    )
)

;========= AUTO CONNECT 2d POLYLINE ==========
;;;; auto conevt 2 pl
(defun c:atc (/ ss ss1 ss2 l td6 e0 l1 t1 e1 co)
 (command "UNDO" "Group")
 (setq co (getstring "Do you want to joint 2D LINE [y/n]:" ))
 (if (= (strcase co nil) "Y") (progn

  (ltopl)
  (setq ss (ssget "X" '((0 . "lwPOLYLINE" ) )  ))
  (if ss (progn
      (setq ss1 ss)
      (setq l (sslength ss))
      (setq td6 0)
      (repeat l
        (setq e0 (ssname ss td6))
        (setq td6 (+ td6 1))
        (if (and (entget e0) (> (sslength  ss1) 0)  ) (progn
              (command "PEDIT" e0 "J" ss1 "" "")
        ))
        (setq ss1 (locss ss1))
      )
  ))
  ))
  (command "UNDO" "end")
)
;;;; auto conevt 2 Line
(defun ltopl (/ ss ss1 ss2 l td7 e0 l1 t1 e1 eg p1 p2)
  (setq ss (ssget "X" '((0 . "LINE" ) )  ))
  (if ss (progn
      (setq ss1 ss)
      (setq l (sslength ss))
      (setq td7 0)
      (repeat l
        (setq e0 (ssname ss td7))
        (setq td7 (+ td7 1))
        (setq eg (entget e0))
        (setq p1 (cdr (assoc 10 eg) ))
        (setq p2 (cdr (assoc 11 eg) ))
        (if (= (nth 2 p1) (nth 2 p2))
              (command "PEDIT" e0 "Y"  "" )
        )
      )
  ))
 ;))
)
;;-----------------------------------
(defun locss (ss1 / ss2 l1 t1 e1)
        (if ss1 (progn
            (setq l1 (sslength ss1))
            (setq t1 0)
            (setq ss2 (ssadd) )
            (repeat l1
                (setq e1 (ssname ss1 t1))
                (setq t1 (+ t1 1))
                (if (entget e1)  (setq ss2 (ssadd e1 ss2) ))
            )
        ))
 (setq ss1 ss2)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;