DIỄN ĐÀN TƯ VẤN XÂY DỰNG THÀNH GIA

Hiện tại bạn đang là khách viếng thăm của Diễn Đàn Tư Vấn Xây Dựng Thành Gia – Nơi Hội Tụ Nhân Tài Xây Dựng. Nếu chưa có tài khoản, xin mời bạn Click chuột vào nút Đăng Ký bên dưới hoặc Click vào nút Đăng Nhập nếu bạn đã là thành viên chính thức để hưởng trọn quyền lợi của Diễn Đàn dành cho bạn. Mọi thắc mắc liên hệ với Ban Quản Trị qua địa chỉ: Ctythanhgia@gmail.com
Cảm ơn bạn đã ghé thăm Diễn Đàn của chúng tôi!
Lưu ý: Bạn chỉ được phép sử dụng Tiếng Việt có dấu hoặc Tiếng Anh trên Diễn Đàn và chỉ có thành viên mới được quyền viết bài, nhận xét trên Diễn Đàn!
Chúc bạn thu được nhiều kiến thức từ việc tham gia Diễn Đàn của chúng ta!
DIỄN ĐÀN TƯ VẤN XÂY DỰNG THÀNH GIA

Chia sẻ tài nguyên chuyên ngành xây dựng

Thông tin Admin


Quản trị: Nguyễn Anh Tuấn
Email: Ctythanhgia@gmail.com
Ctythanhgia@yahoo.com
Điện thoại: 0914.524.611

Latest topics

» Trường Seneca
Sat Jun 16, 2018 9:38 am by nghiagopal

» SOUTHERN OREGON UNIVERSITY
Fri Jun 15, 2018 4:52 pm by nghiagopal

» Sault College
Fri Jun 15, 2018 4:51 pm by nghiagopal

» Tại sao chọn Đại học Oregon?
Tue Jun 12, 2018 9:37 am by nghiagopal

» Tại sao chọn George Brown College?
Tue Jun 12, 2018 9:34 am by nghiagopal

» Điểm nổi bật của Đại học Texas Tech
Mon Jun 11, 2018 3:15 pm by nghiagopal

» Học viện Informatics ở Singapore
Mon Jun 11, 2018 3:14 pm by nghiagopal

» Virginia Commonwealth University
Thu Jun 07, 2018 10:21 am by nghiagopal

» Chương trình thực tập hưởng lương $800-$1200/ tháng tại học viện tin học Singapore
Thu Jun 07, 2018 10:14 am by nghiagopal

» Lambton College (Canada)
Wed Jun 06, 2018 3:30 pm by nghiagopal

Lịch vạn niên

Từ điển online


Tra theo từ điển:



Keywords

Poll

Bạn đang dùng phần mềm dự toán nào?
18% 18% [ 111 ]
34% 34% [ 215 ]
15% 15% [ 94 ]
3% 3% [ 18 ]
6% 6% [ 37 ]
15% 15% [ 95 ]
9% 9% [ 54 ]

Tổng số bầu chọn : 624

Quảng Cáo

free forum

free forum

free forum

free forum

free forum

Statistics

Tổng số bài viết đã gửi vào diễn đàn là 1658 in 1240 subjects

Diễn Đàn hiện có 5685 thành viên

Chúng ta cùng chào mừng thành viên mới đăng ký: LinhChung

Thống Kê

Hiện có 1 người đang truy cập Diễn Đàn, gồm: 0 Thành viên, 0 Thành viên ẩn danh và 1 Khách viếng thăm

Không


[ View the whole list ]


Số người truy cập cùng lúc nhiều nhất là 14 người, vào ngày Tue Jul 26, 2016 12:29 pm

Bản đồ online


Lisp vẽ mái taluy

Share
avatar
Admin
Admin
Admin

Giới tính : Nam Tổng số bài gửi : 826
Sinh nhật : 09/04/1981
Ngày tham gia : 13/08/2011
Tuổi : 37
Việc làm/sở thích : Tư vấn thiết kế, giám sát thi công, quản lý dự án...

default Lisp vẽ mái taluy

Bài gửi by Admin on Thu Mar 01, 2012 8:28 pm

Taluy đắp: TLF
Taluy đào: TLC
Taluy đơn giản: TL

Code:
;;;=======================================
;;; 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)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



[You must be registered and logged in to see this image.]
[You must be registered and logged in to see this image.]

    Hôm nay: Mon Jun 25, 2018 3:35 am