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!

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
Top posters
Admin
 
davitman
 
thaolinhshop2014
 
duancuacuon
 
huynq.231
 
vanvan11
 
lediem_itvn
 
namcdxd
 
dhcompany
 
funnyhouse
 
Latest topics
Lịch vạn niên
Từ điển online

Tra theo từ điển:



Tìm kiếm
 
 

Display results as :
 
Rechercher Advanced Search
Keywords
dung bang vien revit thuc 2012 lieu tinh Nova toan nước TCVN thiết thép công phần nghiep cương trình sketchup tông biệt quản chat HITOSOFT huong
Poll
Bạn đang dùng phần mềm dự toán nào?
Dự toán Acitt
18%
 18% [ 111 ]
Dự toán 97
34%
 34% [ 215 ]
Dự toán G8
15%
 15% [ 94 ]
Dự toán Escon
3%
 3% [ 18 ]
Dự toán Delta
6%
 6% [ 37 ]
Dự toán Hitosoft
15%
 15% [ 95 ]
Dự toán GXD
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
Diễn Đàn hiện có 5657 thành viên
Chúng ta cùng chào mừng thành viên mới đăng ký: TieuThienGA

Tổng số bài viết đã gửi vào diễn đàn là 1585 in 1170 subjects
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

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
Social bookmarking
Social bookmarking Digg  Social bookmarking Delicious  Social bookmarking Reddit  Social bookmarking Stumbleupon  Social bookmarking Slashdot  Social bookmarking Furl  Social bookmarking Yahoo  Social bookmarking Google  Social bookmarking Blinklist  Social bookmarking Blogmarks  Social bookmarking Technorati  

Bookmark and share the address of DIỄN ĐÀN TƯ VẤN XÂY DỰNG THÀNH GIA on your social bookmarking website

Share|

Lisp vẽ mái taluy

Xem chủ đề cũ hơn Xem chủ đề mới hơn Go down
Tác giảThông điệp
Admin
Admin
Admin


Giới tính : Nam
Tổng số bài gửi : 801
Sinh nhật : 16/01/1980
Ngày tham gia : 13/08/2011
Tuổi : 36
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...
Admin Tình Trạng:
Cấp bậc: Admin
Danh vọng:801%/1000%
Tài năng:36%/100%


Bài gửiTiêu đề: Lisp vẽ mái taluy 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)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Chữ ký của thànhviên


[You must be registered and logged in to see this image.]
[You must be registered and logged in to see this image.]
Về Đầu Trang Go down
http://banxaydung.blogspot.com/

Lisp vẽ mái taluy

Xem chủ đề cũ hơn Xem chủ đề mới hơn Về Đầu Trang
.:Viêt tiếng việt có dấu..là tôn trọng người đọc:.
.::Chia sẻ bài viết và ghi rõ nguồn là tôn trọng người viết::.
.:::Thực hiện 2 điều trên là tôn trọng chính mình:::.
Trang 1 trong tổng số 1 trang

Permissions in this forum:Bạn không có quyền trả lời bài viết
DIỄN ĐÀN TƯ VẤN XÂY DỰNG THÀNH GIA :: THƯ VIỆN XÂY DỰNG :: Autocad & Autolisp cad-
Chuyển đến:

Design by: Nguyễn Anh Tuấn
Copyright ©2000-2011, Licensed to vBulletin 3.8.0
Diễn đàn được đóng góp nội dung, phát triển bởi các thành viên.
Truy cập, sử dụng diễn đàn này nghĩa là bạn đã chấp nhận QUY ÐỊNH của diễn đàn
Thành Gia v1.4 Copyright ©2000 - 2011 Jelsoft Enterprises Limited, PixelFX Studios


Free forum | © phpBB | Free forum support | Liên hệ | Report an abuse | www.sosblogs.com