Free Auto Lisp

st788796 · 发表于 2013-10-4 00:26:25

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;; convert a selection set to a list, aka SS_ssL SS_Lss
(defun SS_EnL (ss / L i)
(setq i 0
@u "SS~Enl"
)
(repeat (if ss
(ssLength ss)
0
)
;; errors on non ss
(setq L (cons (ssname ss i) L)
i (1+ i)
)
)
L
)
;; ed
;; convert a list to a selection set, aka Lss_SS
(defun EnL_SS (L / e ss)
(setq ss (ssadd))
(foreach e L (ssadd e ss))
ss
)
;; point functions
;; Coordinate System conversions, with point data test
(DeFun U_W (p)
(if (Pnt_P p)
(trans p 1 0)
)
)
;; Ucs to World
(DeFun W_U (p)
(if (Pnt_P p)
(trans p 0 1)
)
)
;; World to Ucs
;; universal associated entity data, like Itm Itm_ Itm_EU
(defun Dxf_ (n dl) (cdr (assoc n dl)))
;; return User coords
(DeFun Dxf_EU (gn edL / vv)
(if (and (setq vv (cdr (assoc gn edL)))
(member gn (list 10 11 210))
)
;; others may exist!!!
(trans vv (cdr (assoc -1 edl)) 1)
vv
)
)
;; return World coords,
(DeFun Dxf_EW (gn edL / vv)
(if (and (setq vv (cdr (assoc gn edL)))
(member gn (list 10 11 210))
)
;; others may exist!!!
(trans vv (cdr (assoc -1 edl)) 0)
vv
)
)
;; grdraw X by point, size relative to 1/30 viewsize
(defun grx (p / z q)
(if (Pnt_P p)
(progn
(setq z (/ (getvar "viewsize") 30)
q (/ pi 4)
)
(grdraw (poLar p q z) (poLar p (* 5 q) z) -1)
(grdraw (poLar p (* 3 q) z) (poLar p (* 7 q) z) -1)
)
(princ " grx-Not-point ")
)
p
)
;;
;; X in display by ucs, tested by Pnt_P
(defun Gr_Xdc (p d c / sz 1qp p0)
;; graphic X size, coLor
(if (Pnt_P p)
(progn
(setq sz (* d (/ (getvar "viewsize") 50))
1qp (/ pi 4)
)
(grdraw (poLar p 1qp sz) (poLar p (* 5 1qp) sz) c)
(grdraw (poLar p (* 3 1qp) sz) (poLar p (* 7 1qp) sz) c)
p
)
)
)
;;
;; graphic box by center, diagonal relative to 1/50 viewsize, color
(defun Gr_Bxc (p d c / sz qpi p1 p2 p3 p4)
(setq sz (* d (/ (getvar "viewsize") 50))
qpi (/ pi 4)
)
(setq p1 (poLar p qpi sz)
p3 (poLar p (* 5 qpi) sz)
p2 (poLar p (* 3 qpi) sz)
p4 (poLar p (* 7 qpi) sz)
)
(grdraw p1 p2 c)
(grdraw p3 p2 c)
(grdraw p3 p4 c)
(grdraw p1 p4 c)
(list p1 p2 p3 p4)
P
)
;; grdraw point List w/o cLosure
(DEFUN Gr_PLc (pL c / p pp)
(if pL
(progn
(setq pp (car pL)
pL (cdr pL)
)
(foreach p pL (grdraw p pp c) (setq pp p))
p
)
)
pL
)
;; Gr_Plc grdraw point List w/cLosure
(DEFUN Gr_PLcC (pL c / p pp vl)
(foreach p pl
(if (Pnt_P p)
(setq vl (cons p vl))
(princ " _PLcC-Not-Pt ")
)
)
(if vL
(progn (setq pp (car vL))
(foreach p (cdr vL) (grdraw p pp c) (setq pp p))
(grdraw pp (car vl) c)
)
)
vL
)
;; X in display by ucs
(defun Gr_Xdc (p d c / sz 1qp p0)
;; graphic X size, coLor
(if (Pnt_P p)
(progn
;;(setq p0 (U_W p)) (command "ucs" "v")(setq p (W_U p0))
(setq sz (* d (/ (getvar "viewsize") 50))
1qp (/ pi 4)
)
(grdraw (poLar p 1qp sz) (poLar p (* 5 1qp) sz) c)
(grdraw (poLar p (* 3 1qp) sz) (poLar p (* 7 1qp) sz) c)
;;(command "ucs" "p") ;; DCS
p
)
)
)
;;
;; pt on p1-p2 as a perp from rp, planar: 2D, same Coord Sys;;
(defun Perp_P (rp p1 p2 / rp1)
(setq rp1 (poLar rp (+ (angLe p1 p2) (/ pi 2)) 1.0))
(inters rp1 rp p1 p2 niL)
)
;; ray intersection
;; point proof: quaLify List as a 2D or 3D point
(DEFUN Pnt_P (p / e l)
;; Does NOT add a Z value to a 2D
(if (and p (Listp p) (or (= (Length p) 3) (= (Length p) 2)))
(foreach e p
(if (numberp e)
(setq l (cons e L))
)
)
)
(if (and l (> (length l) 1))
p
)
)
;;
;; point proof - quaLify 2 or 3 reals List, return a 3D point
(DEFUN Pnt_P3D (p / rp e l pf)
(setq pf t)
(cond
((and p (Listp p) (= (Length p) 2))
(foreach e p
(if (not (and e (numberp e)))
(setq pf nil)
)
)
(if pf
(list (float (car p)) (float (cadr p)) 0.0)
)
)
((and p (Listp p) (= (Length p) 3))
(foreach e p
(if (not (and e (numberp e)))
(setq pf nil)
)
)
(if pf
(list (float (car p))
(float (cadr p))
(float (caddr p))
)
)
)
)
)
;;
;; get point, default, dislay coords
(defun get_P (dp ps) (get_P23x dp ps))
;;
;; GET_PRD get point with ref pt, default pt _prd
(Defun get_prd (rp dp ps / ans x)
(if (pnt_p dp)
(gr_xdc dp 1 1)
(setq dp nil)
)
(if (pnt_p rp)
(gr_bdc rp 77 2)
(setq rp nil)
)
;; (if (and dp rp) (grdraw rp dp 2) )
(setq ps (if dp
(strcat ps "<" (pnt_str23 dp) "> ")
ps
)
ans (if (pnt_p rp)
(getpoint rp ps)
(getpoint ps)
)
)
(if dp
(gr_xdc dp 1 -1)
)
(if rp
(gr_bdc rp 1 -2)
)
(if ans
ans
dp
)
)
;; point to string Pnt_str
(defun Pnt_Str23 (p / q)
(cond ((not (Pnt_P p)) " nil ")
((= 3 (setq q (length p)))
(strcat (rtos (car p) 2 3)
","
(rtos (cadr p) 2 3)
","
(rtos (cAddr p) 2 3)
)
)
((= 2 q)
(strcat (rtos (car p) 2 3)
","
(rtos (cadr p) 2 3)
)
)
)
)
;; get point w default;;
;; uses Gr_xdc, str_P, Pnt_P, Pnt_str23
(defun get_P23x (dp ps / ans)
(graphscr)
(setq ps (if (str_P ps)
ps
" Get Pt "
)
)
(if (Pnt_P dp)
(gr_xdc dp 1 1)
)
(setq ans (if (Pnt_P dp)
(getpoint dp (strcat ps "<" (Pnt_str23 dp) ">"))
(getpoint ps)
)
)
(if ans
ans
dp
)
)
;; Gr_Bdc box in dispaly by ucs
(defun gr_bdc (p d c / sz qpi p1 p2 p3 p4 p0)
(if (pnt_p p)
(progn
(setq sz (* d (/ (getvar "viewsize") 50))
qpi (/ pi 4)
)
(setq p1 (poLar p qpi sz)
p3 (poLar p (* 5 qpi) sz)
p2 (poLar p (* 3 qpi) sz)
p4 (poLar p (* 7 qpi) sz)
)
(grdraw p1 p2 c)
(grdraw p3 p2 c)
(grdraw p3 p4 c)
(grdraw p1 p4 c)
(List p1 p2 p3 p4)
)
)
)
;; input yes no
(defun i_yn (qstr ynflg / tf nf it ig k)
;;
(princ (strcat qstr
(if ynflg
" N or < Y > "
" Y or < N > "
)
)
)
(while (and (setq it (car (setq ig (grread T))))
(/= 6 it)
(setq ik (cadr ig))
;; key maybe
(not (and (= 2 it)
(or ;; key board
(setq nf (or (= 110 ik) (= 78 ik)))
(setq tf (or (= 121 ik) (= 89 ik)))
(= 13 ik)
(= 32 ik)
)
)
)
(not (= it 11))
)
)
;; end while ;; mou R
(setq ynflg (cond (nf nil)
(tf t)
(t ynflg)
)
)
(princ (if ynflg
" Y "
" N "
)
)
ynflg
)
;; getint w default/0, prompt
(DeFun Get_I (d ps / a)
(setq d (if (and d (= 'INT (type d)))
d
0
)
a (getint (strcat " " ps " < " (itoa d) " > "))
)
(if a
a
d
)
)
;; GET_D, with Default value, D. AusCadd.com
(Defun Get_D (d s / ans)
(setq d (if (numberp d)
d
1.0
)
ans (getdist (strcat " " s " < " (rtos d 2 4) " > "))
)
(if ans
ans
d
)
)
;; get real, 4 places, uses Str_P
(DeFun Get_R (d ps / ans)
(setq d (if (and d (numberp d))
d
0
)
;; default
ps (if (str_p ps)
ps
"\n Enter Number: "
)
ans (getreal (strcat " " ps " < " (rtos d 2 4) " > "))
)
(if ans
ans
d
)
)
;; print a line feed and the string argument, return nil
(defun pp_nil (s) (princ (strcat "\n " s " ")) nil)
;; print a line feed and the string argument, error out callously
(defun exit_s (s) (princ "\n Exit: ") (princ s) (exit))
;; String proof
(defun STR_P (S) (and s (= 'STR (type s))))
;; string to characters list
(defun S_ChrL (s / n cl)
(setq n (if (and s (str_P s))
(strLen s)
)
)
(repeat n
(setq cl (cons (substr s n 1) cL)
n (1- n)
)
)
cL
)
;;
;; Getstring with Default, no test for prompt string, no spaces
(defun Get_S (ds ps / gs)
(if (not (STR_P ds))
(setq ds "-")
)
(setq gs (strcase (getstring (strcat ;; not incLude spaces
ps
" < "
ds
" > "
)
)
)
)
(if (= "" gs)
ds
gs
)
)
;; input Y or y key to exit loop;; prompt string once, optional
(defun Get_YKey (qstr / it ig k donef)
(princ qstr)
(while (not donef)
(if (and (setq it (car (setq ig (grread T))))
(/= 6 it)
(setq ik (cadr ig))
;; maybe
(or (= 121 ik) (= 89 ik))
)
;; Is a Y or y
(setq donef t)
)
)
)
;; AusCadd.com
;; implementation
(while (not (get_Ykey "\n Press Y to run, Escape to Quit: "))
)
;; or, (while (not (get_Ykey "\n Press Y: " ))) ;; Y, or y, to go
;; or, (while (not (get_Ykey "" ))) ;; no comment
;; parse string s1 into a List by deLimiter characters from List dcL
(defun pars_cL (s1 dcL / sLen i sumLst subLst s2 L2)
(setq sLen (strLen s1)
s2 ""
i 0
@u "pars_cL"
)
;; 1st, others
(whiLe (< i slen)
(setq i (1+ i)
c (substr s1 i 1)
)
;;
(if (not (member c dcL))
(setq s2 (strcat s2 c))
(if (/= "" s2)
(setq L2 (cons s2 L2)
s2 ""
)
)
)
)
;;
(if (/= "" s2)
(setq L2 (cons s2 L2)
s2 ""
)
)
;;
(if L2
(reverse L2)
)
)
;; parse RS by space character delimiter into a List of strs
(defun pars_s (RS / d L i a b Q n)
(setq @u "pars_s"
i 1
d " "
)
(if (and rs (= 'STR (type rs)) (setq Q (strLen rs)))
(whiLe (<= i Q)
(whiLe (and (= (substr rs i 1) d) (<= i Q)) (setq i (1+ i)))
(setq n i)
(whiLe (and (/= (substr rs i 1) d) (<= i Q))
(setq i (1+ i))
)
(setq a (substr rs n (- i n))
i (1+ i)
)
(if (and a (/= "" a))
(setq L (cons a L))
)
)
)
(if L
(reverse L)
)
)
;; parse refstr rs by comma delimiter into a List of strs
(defun pars_c (rs / d L i a b Q n)
(setq @u "pars_c"
i 1
d ","
)
(if (and rs (= 'STR (type rs)) (setq Q (strLen rs)))
(whiLe (<= i Q)
(whiLe (and (= (substr rs i 1) d) (<= i Q)) (setq i (1+ i)))
(setq n i)
(whiLe (and (/= (substr rs i 1) d) (<= i Q))
(setq i (1+ i))
)
(setq a (substr rs n (- i n))
i (1+ i)
)
(if (and a (/= "" a))
(setq L (cons a L))
)
)
)
(if L
(reverse L)
)
)
;; miLitary date time
(defun date_miLhr (ds / d mns mn ms)
(if (or (not ds) (/= 'STR (type ds)))
(setq ds (getvar "cdate"))
)
(setq d (rtos ds 2 6)
mns (substr d 5 2)
mn (1- (atoi mns))
)
(setq ms (nth mn
(List "JAN" "FEB" "MAR" "APR" "MAY"
"JUN" "JUL" "AUG" "SEP" "OCT"
"NOV" "DEC"
)
)
)
(strcat (substr d 10 2)
(substr d 12 2)
":"
(substr d 7 2)
ms
(substr d 3 2)
)
)
;; miLitary date
(defun date_miL (ds /)
(if (or (not ds) (/= 'STR (type ds)))
(setq ds (getvar "cdate"))
)
(setq d (rtos ds 2 6)
mns (substr d 5 2)
mn (1- (atoi mns))
)
(setq ms (nth mn
(List "JAN" "FEB" "MAR" "APR" "MAY"
"JUN" "JUL" "AUG" "SEP" "OCT"
"NOV" "DEC"
)
)
)
(strcat (substr d 7 2) ms (substr d 3 2))
)
;; Lists
;; add Lists w/o dups
(defun L_addu (L1 L2 / e La)
(setq La '())
(foreach e L1
(if (not (member e La))
(setq La (cons e La))
)
)
(foreach e L2
(if (not (member e La))
(setq La (cons e La))
)
)
(if La
(reverse La)
)
)
;; list of strings to a file
(defun L_File (L fn / e fh1)
(if (setq Fh1 (open fn "w"))
(progn (foreach e L (write-line e Fh1)) (close fh1) fn)
)
)
;; file to list of strings
(defun File_l (fn / fh L rl)
(if (setq Fh (open fn "r"))
(while (setq rl (read-line Fh)) (setq L (cons rl L)))
)
(if fh
(close fh)
(progn (princ "\n no-file-found: ") (prin1 fn))
)
(if L
(reverse L)
)
)
;; list of strings to file, by append -SCG- 12/00
(defun L_FiLe_Append (L fn / e fh olderr)
(setq olderr *ERROR*)
(defun *error* (s)
(princ "\n ERR L_fiLe_append: ")
(princ s)
(if fh
(close fh)
)
(princ)
)
(if (setq Fh (open fn "a"))
(progn (foreach e L
(if (and e (str_P e))
(write-Line e Fh)
(princ "\n L_fiLe_append, not-str. ")
)
)
(cLose fh)
)
)
(setq *error* olderr)
fn
)
;; Sort by Ascending X, Vl_SortCar
(defun sort_x (pL)
(vl-sort pL (function (lambda (x y) (> (car x) (car y)))))
)
;; Sort by Descending Y
(defun sort_>y (pL)
(vl-sort pL (function (lambda (x y) (> (cadr x) (cadr y)))))
)
;; special apss, in development:
;; 9/16" Alternating PL Width,
(defun c:9PL (/ rl)
(if (setq rl (PL_Vwd 0 (/ 9 16.0)))
(princ
(strcat "\n Segments: " (itoa (car rl)) ", and done.")
)
(princ "\n 9PL NOT done ")
)
(princ)
)
;;
;; 5/16" Alternating PL Width,
(defun c:5PL (/ rl)
(if (setq rl (PL_Vwd 0 (/ 5 16.0)))
(princ
(strcat "\n Segments: " (itoa (car rl)) ", and done.")
)
(princ "\n 9PL NOT done ")
)
(princ)
)
;;
;; 3/16" Alternating PL Width,
(defun c:3PL (/ rl)
(if (setq rl (PL_Vwd 0 (/ 3 16.0)))
(princ
(strcat "\n Segments: " (itoa (car rl)) ", and done.")
)
(princ "\n 9PL NOT done ")
)
(princ)
)
;;
;; Variabl PL Width, return Segs, ename
(defun PL_Vwd (W1 W2 / np Wf Q W pnp elas1 elas)
(setq Q -1
W W1
;; start width #1 anyway
elas1
(entlast)
)
;; pnp Wf are nil to start, local var preserve Prev Next Pt,
(while (or (and pnp
(setq np (getpoint pnp
(strcat
"\n Next Point: "
(itoa (1+ Q))
" W: "
(rtos W 4 1)
)
)
)
)
(and (not pnp)
(setq np (getpoint (strcat
"\n Next Point: "
(itoa (1+ Q))
" W: "
(rtos W 4 1)
)
)
)
)
)
(if (not pnp)
(command "pline")
)
;;
(command np
"w"
(if Wf
W2
W1
)
(if Wf
W1
W2
)
)
(setq Wf (not Wf)
Q (1+ Q)
pnp np
W (if Wf
W1
W2
)
)
)
(IF pnp
(progn (COMMAND)
;; or not created
(setq elas (entlast))
(if (and elas (or (not elas1) (not (eq elas elas1))))
(list Q elas)
)
)
)
;; segs and name, nil if not
)
;;

;; convert a selection set to a list, aka SS_ssL SS_Lss 
(defun SS_EnL (ss / L i) 
  (setq i  0 
 @u "SS~Enl" 
  ) 
  (repeat (if ss 
     (ssLength ss) 
     0 
   ) 
    ;; errors on non ss 
    (setq L (cons (ssname ss i) L) 
   i (1+ i) 
    ) 
  ) 
  L 
) 
;; ed 
;; convert a list to a selection set, aka Lss_SS 
(defun EnL_SS (L / e ss) 
  (setq ss (ssadd)) 
  (foreach e L (ssadd e ss)) 
  ss 
) 
 
;; point functions 
;; Coordinate System conversions, with point data test 
(DeFun U_W (p) 
  (if (Pnt_P p) 
    (trans p 1 0) 
  ) 
) 
;; Ucs to World 
(DeFun W_U (p) 
  (if (Pnt_P p) 
    (trans p 0 1) 
  ) 
) 
;; World to Ucs 
;; universal associated entity data, like Itm  Itm_  Itm_EU 
(defun Dxf_ (n dl) (cdr (assoc n dl))) 
;; return User coords 
(DeFun Dxf_EU (gn edL / vv) 
  (if (and (setq vv (cdr (assoc gn edL))) 
    (member gn (list 10 11 210)) 
      ) 
    ;; others may exist!!! 
    (trans vv (cdr (assoc -1 edl)) 1) 
    vv 
  ) 
) 
;; return World coords, 
(DeFun Dxf_EW (gn edL / vv) 
  (if (and (setq vv (cdr (assoc gn edL))) 
    (member gn (list 10 11 210)) 
      ) 
    ;; others may exist!!! 
    (trans vv (cdr (assoc -1 edl)) 0) 
    vv 
  ) 
) 
 
;; grdraw X by point, size relative to 1/30 viewsize 
(defun grx (p / z q) 
  (if (Pnt_P p) 
    (progn 
      (setq z (/ (getvar "viewsize") 30) 
     q (/ pi 4) 
      ) 
      (grdraw (poLar p q z) (poLar p (* 5 q) z) -1) 
      (grdraw (poLar p (* 3 q) z) (poLar p (* 7 q) z) -1) 
    ) 
    (princ " grx-Not-point ") 
  ) 
  p 
) 
;; 
 
;; X in display by ucs, tested by Pnt_P   
(defun Gr_Xdc (p d c / sz 1qp p0) 
  ;; graphic X size, coLor 
  (if (Pnt_P p) 
    (progn 
      (setq sz (* d (/ (getvar "viewsize") 50)) 
     1qp (/ pi 4) 
      ) 
      (grdraw (poLar p 1qp sz) (poLar p (* 5 1qp) sz) c) 
      (grdraw (poLar p (* 3 1qp) sz) (poLar p (* 7 1qp) sz) c) 
      p 
    ) 
  ) 
) 
;; 
 
;; graphic box by center, diagonal relative to 1/50 viewsize, color 
(defun Gr_Bxc (p d c / sz qpi p1 p2 p3 p4) 
  (setq sz  (* d (/ (getvar "viewsize") 50)) 
 qpi (/ pi 4) 
  ) 
  (setq p1 (poLar p qpi sz) 
 p3 (poLar p (* 5 qpi) sz) 
 p2 (poLar p (* 3 qpi) sz) 
 p4 (poLar p (* 7 qpi) sz) 
  ) 
  (grdraw p1 p2 c) 
  (grdraw p3 p2 c) 
  (grdraw p3 p4 c) 
  (grdraw p1 p4 c) 
  (list p1 p2 p3 p4) 
  P 
) 
 
;; grdraw point List w/o cLosure 
(DEFUN Gr_PLc (pL c / p pp) 
  (if pL 
    (progn 
      (setq pp (car pL) 
     pL (cdr pL) 
      ) 
      (foreach p pL (grdraw p pp c) (setq pp p)) 
      p 
    ) 
  ) 
  pL 
) 
 
;; Gr_Plc grdraw point List w/cLosure 
(DEFUN Gr_PLcC (pL c / p pp vl) 
  (foreach p pl 
    (if (Pnt_P p) 
      (setq vl (cons p vl)) 
      (princ " _PLcC-Not-Pt ") 
    ) 
  ) 
  (if vL 
    (progn (setq pp (car vL)) 
    (foreach p (cdr vL) (grdraw p pp c) (setq pp p)) 
    (grdraw pp (car vl) c) 
    ) 
  ) 
  vL 
) 
 
;; X in display by ucs 
(defun Gr_Xdc (p d c / sz 1qp p0) 
  ;; graphic X size, coLor 
  (if (Pnt_P p) 
    (progn 
      ;;(setq p0 (U_W p)) (command "ucs" "v")(setq p (W_U p0)) 
      (setq sz (* d (/ (getvar "viewsize") 50)) 
     1qp (/ pi 4) 
      ) 
      (grdraw (poLar p 1qp sz) (poLar p (* 5 1qp) sz) c) 
      (grdraw (poLar p (* 3 1qp) sz) (poLar p (* 7 1qp) sz) c) 
      ;;(command "ucs" "p")  ;; DCS 
      p 
    ) 
  ) 
) 
;; 
 
;; pt on p1-p2 as a perp from rp, planar: 2D, same Coord Sys;; 
(defun Perp_P (rp p1 p2 / rp1) 
  (setq rp1 (poLar rp (+ (angLe p1 p2) (/ pi 2)) 1.0)) 
  (inters rp1 rp p1 p2 niL) 
) 
;; ray intersection 
 
;; point proof: quaLify List as a 2D or 3D point 
(DEFUN Pnt_P (p / e l) 
  ;; Does NOT add a Z value to a 2D 
  (if (and p (Listp p) (or (= (Length p) 3) (= (Length p) 2))) 
    (foreach e p 
      (if (numberp e) 
 (setq l (cons e L)) 
      ) 
    ) 
  ) 
  (if (and l (> (length l) 1)) 
    p 
  ) 
) 
;; 
 
;; point proof - quaLify 2 or 3 reals List, return a 3D point 
(DEFUN Pnt_P3D (p / rp e l pf) 
  (setq pf t) 
  (cond 
    ((and p (Listp p) (= (Length p) 2)) 
     (foreach e p 
       (if (not (and e (numberp e))) 
  (setq pf nil) 
       ) 
     ) 
     (if pf 
       (list (float (car p)) (float (cadr p)) 0.0) 
     ) 
    ) 
    ((and p (Listp p) (= (Length p) 3)) 
     (foreach e p 
       (if (not (and e (numberp e))) 
  (setq pf nil) 
       ) 
     ) 
     (if pf 
       (list (float (car p)) 
      (float (cadr p)) 
      (float (caddr p)) 
       ) 
     ) 
    ) 
  ) 
) 
;; 
 
;; get point, default, dislay coords 
(defun get_P (dp ps) (get_P23x dp ps)) 
;;   
 
;; GET_PRD  get point with ref pt, default pt _prd 
(Defun get_prd (rp dp ps / ans x) 
  (if (pnt_p dp) 
    (gr_xdc dp 1 1) 
    (setq dp nil) 
  ) 
  (if (pnt_p rp) 
    (gr_bdc rp 77 2) 
    (setq rp nil) 
  ) 
  ;; (if (and dp rp) (grdraw rp dp 2) )    
  (setq ps  (if dp 
       (strcat ps "<" (pnt_str23 dp) "> ") 
       ps 
     ) 
 ans (if (pnt_p rp) 
       (getpoint rp ps) 
       (getpoint ps) 
     ) 
  ) 
  (if dp 
    (gr_xdc dp 1 -1) 
  ) 
  (if rp 
    (gr_bdc rp 1 -2) 
  ) 
  (if ans 
    ans 
    dp 
  ) 
) 
 
;; point to string Pnt_str 
(defun Pnt_Str23 (p / q) 
  (cond ((not (Pnt_P p)) " nil ") 
 ((= 3 (setq q (length p))) 
  (strcat (rtos (car p) 2 3) 
   "," 
   (rtos (cadr p) 2 3) 
   "," 
   (rtos (cAddr p) 2 3) 
  ) 
 ) 
 ((= 2 q) 
  (strcat (rtos (car p) 2 3) 
   "," 
   (rtos (cadr p) 2 3) 
  ) 
 ) 
  ) 
) 
 
;; get point w default;; 
;; uses Gr_xdc, str_P, Pnt_P, Pnt_str23 
(defun get_P23x (dp ps / ans) 
  (graphscr) 
  (setq ps (if (str_P ps) 
      ps 
      " Get Pt " 
    ) 
  ) 
  (if (Pnt_P dp) 
    (gr_xdc dp 1 1) 
  ) 
  (setq ans (if (Pnt_P dp) 
       (getpoint dp (strcat ps "<" (Pnt_str23 dp) ">")) 
       (getpoint ps) 
     ) 
  ) 
  (if ans 
    ans 
    dp 
  ) 
) 
 
;; Gr_Bdc box in dispaly by ucs 
(defun gr_bdc (p d c / sz qpi p1 p2 p3 p4 p0) 
  (if (pnt_p p) 
    (progn 
      (setq sz (* d (/ (getvar "viewsize") 50)) 
     qpi (/ pi 4) 
      ) 
      (setq p1 (poLar p qpi sz) 
     p3 (poLar p (* 5 qpi) sz) 
     p2 (poLar p (* 3 qpi) sz) 
     p4 (poLar p (* 7 qpi) sz) 
      ) 
      (grdraw p1 p2 c) 
      (grdraw p3 p2 c) 
      (grdraw p3 p4 c) 
      (grdraw p1 p4 c) 
      (List p1 p2 p3 p4) 
    ) 
  ) 
) 
 
;; input yes no 
(defun i_yn (qstr ynflg / tf nf it ig k) 
  ;; 
  (princ (strcat qstr 
   (if ynflg 
     " N or < Y > " 
     " Y or < N > " 
   ) 
  ) 
  ) 
  (while (and (setq it (car (setq ig (grread T)))) 
       (/= 6 it) 
       (setq ik (cadr ig)) 
       ;; key maybe 
       (not (and (= 2 it) 
   (or ;; key board 
       (setq nf (or (= 110 ik) (= 78 ik))) 
       (setq tf (or (= 121 ik) (= 89 ik))) 
       (= 13 ik) 
       (= 32 ik) 
   ) 
     ) 
       ) 
       (not (= it 11)) 
  ) 
  ) 
  ;; end while  ;; mou R 
  (setq ynflg (cond (nf nil) 
      (tf t) 
      (t ynflg) 
       ) 
  ) 
  (princ (if ynflg 
    " Y " 
    " N " 
  ) 
  ) 
  ynflg 
) 
 
;; getint w default/0, prompt 
(DeFun Get_I (d ps / a) 
  (setq d (if (and d (= 'INT (type d))) 
     d 
     0 
   ) 
 a (getint (strcat " " ps " < " (itoa d) " > ")) 
  ) 
  (if a 
    a 
    d 
  ) 
) 
;; GET_D,  with Default value, D.   AusCadd.com 
(Defun Get_D (d s / ans) 
  (setq d   (if (numberp d) 
       d 
       1.0 
     ) 
 ans (getdist (strcat " " s " < " (rtos d 2 4) " > ")) 
  ) 
  (if ans 
    ans 
    d 
  ) 
) 
;; get real,  4 places, uses Str_P 
(DeFun Get_R (d ps / ans) 
  (setq d   (if (and d (numberp d)) 
       d 
       0 
     ) 
 ;; default 
 ps  (if (str_p ps) 
       ps 
       "\n Enter Number:  " 
     ) 
 ans (getreal (strcat " " ps " < " (rtos d 2 4) " > ")) 
  ) 
  (if ans 
    ans 
    d 
  ) 
) 
 
;; print a line feed and the string argument, return nil 
(defun pp_nil (s) (princ (strcat "\n " s " ")) nil) 
 
;; print a line feed and the string argument, error out callously 
(defun exit_s (s) (princ "\n Exit: ") (princ s) (exit)) 
 
;; String proof 
(defun STR_P (S) (and s (= 'STR (type s)))) 
 
;; string to characters list 
(defun S_ChrL (s / n cl) 
  (setq n (if (and s (str_P s)) 
     (strLen s) 
   ) 
  ) 
  (repeat n 
    (setq cl (cons (substr s n 1) cL) 
   n  (1- n) 
    ) 
  ) 
  cL 
) 
;; 
 
;; Getstring with Default, no test for prompt string, no spaces 
(defun Get_S (ds ps / gs) 
  (if (not (STR_P ds)) 
    (setq ds "-") 
  ) 
  (setq gs (strcase (getstring (strcat ;; not incLude spaces 
           ps 
           " < " 
           ds 
           " > " 
          ) 
      ) 
    ) 
  ) 
  (if (= "" gs) 
    ds 
    gs 
  ) 
) 
 
;; input Y or y key to exit loop;; prompt string once, optional 
(defun Get_YKey (qstr / it ig k donef) 
  (princ qstr) 
  (while (not donef) 
    (if (and (setq it (car (setq ig (grread T)))) 
      (/= 6 it) 
      (setq ik (cadr ig)) 
      ;; maybe          
      (or (= 121 ik) (= 89 ik)) 
 ) 
      ;; Is a Y or y 
      (setq donef t) 
    ) 
  ) 
) 
;; AusCadd.com 
;; implementation 
(while (not (get_Ykey "\n Press Y to run, Escape to Quit: ")) 
) 
;; or, (while (not (get_Ykey "\n Press Y: " ))) ;; Y, or y, to go 
;; or, (while (not (get_Ykey "" ))) ;; no comment 
 
;; parse string s1 into a List by deLimiter characters from List dcL 
(defun pars_cL (s1 dcL / sLen i sumLst subLst s2 L2) 
  (setq sLen (strLen s1) 
 s2   "" 
 i    0 
 @u   "pars_cL" 
  ) 
  ;; 1st,  others 
  (whiLe (
    (setq i (1+ i) 
   c (substr s1 i 1) 
    ) 
    ;; 
    (if (not (member c dcL)) 
      (setq s2 (strcat s2 c)) 
      (if (/= "" s2) 
 (setq L2 (cons s2 L2) 
       s2 "" 
 ) 
      ) 
    ) 
  ) 
  ;; 
  (if (/= "" s2) 
    (setq L2 (cons s2 L2) 
   s2 "" 
    ) 
  ) 
  ;; 
  (if L2 
    (reverse L2) 
  ) 
) 
 
;; parse RS by space character delimiter  into a List of strs 
(defun pars_s (RS / d L i a b Q n) 
  (setq @u "pars_s" 
 i  1 
 d  " " 
  ) 
  (if (and rs (= 'STR (type rs)) (setq Q (strLen rs))) 
    (whiLe (<= i Q) 
      (whiLe (and (= (substr rs i 1) d) (<= i Q)) (setq i (1+ i))) 
      (setq n i) 
      (whiLe (and (/= (substr rs i 1) d) (<= i Q)) 
 (setq i (1+ i)) 
      ) 
      (setq a (substr rs n (- i n)) 
     i (1+ i) 
      ) 
      (if (and a (/= "" a)) 
 (setq L (cons a L)) 
      ) 
    ) 
  ) 
  (if L 
    (reverse L) 
  ) 
) 
 
;; parse refstr rs by comma delimiter  into a List of strs 
(defun pars_c (rs / d L i a b Q n) 
  (setq @u "pars_c" 
 i  1 
 d  "," 
  ) 
  (if (and rs (= 'STR (type rs)) (setq Q (strLen rs))) 
    (whiLe (<= i Q) 
      (whiLe (and (= (substr rs i 1) d) (<= i Q)) (setq i (1+ i))) 
      (setq n i) 
      (whiLe (and (/= (substr rs i 1) d) (<= i Q)) 
 (setq i (1+ i)) 
      ) 
      (setq a (substr rs n (- i n)) 
     i (1+ i) 
      ) 
      (if (and a (/= "" a)) 
 (setq L (cons a L)) 
      ) 
    ) 
  ) 
  (if L 
    (reverse L) 
  ) 
) 
 
;; miLitary date time 
(defun date_miLhr (ds / d mns mn ms) 
  (if (or (not ds) (/= 'STR (type ds))) 
    (setq ds (getvar "cdate")) 
  ) 
  (setq d   (rtos ds 2 6) 
 mns (substr d 5 2) 
 mn  (1- (atoi mns)) 
  ) 
  (setq ms (nth mn 
  (List "JAN"    "FEB" "MAR"  "APR"   "MAY" 
        "JUN"    "JUL" "AUG"  "SEP"   "OCT" 
        "NOV"    "DEC" 
       ) 
    ) 
  ) 
  (strcat (substr d 10 2) 
   (substr d 12 2) 
   ":" 
   (substr d 7 2) 
   ms 
   (substr d 3 2) 
  ) 
) 
 
;; miLitary date 
(defun date_miL (ds /) 
  (if (or (not ds) (/= 'STR (type ds))) 
    (setq ds (getvar "cdate")) 
  ) 
  (setq d   (rtos ds 2 6) 
 mns (substr d 5 2) 
 mn  (1- (atoi mns)) 
  ) 
  (setq ms (nth mn 
  (List "JAN"    "FEB" "MAR"  "APR"   "MAY" 
        "JUN"    "JUL" "AUG"  "SEP"   "OCT" 
        "NOV"    "DEC" 
       ) 
    ) 
  ) 
  (strcat (substr d 7 2) ms (substr d 3 2)) 
) 
 
;; Lists 
;; add Lists w/o dups 
(defun L_addu (L1 L2 / e La) 
  (setq La '()) 
  (foreach e L1 
    (if (not (member e La)) 
      (setq La (cons e La)) 
    ) 
  ) 
  (foreach e L2 
    (if (not (member e La)) 
      (setq La (cons e La)) 
    ) 
  ) 
  (if La 
    (reverse La) 
  ) 
) 
 
;; list of strings to a file 
(defun L_File (L fn / e fh1) 
  (if (setq Fh1 (open fn "w")) 
    (progn (foreach e L (write-line e Fh1)) (close fh1) fn) 
  ) 
) 
 
;; file to list of strings 
(defun File_l (fn / fh L rl) 
  (if (setq Fh (open fn "r")) 
    (while (setq rl (read-line Fh)) (setq L (cons rl L))) 
  ) 
  (if fh 
    (close fh) 
    (progn (princ "\n no-file-found: ") (prin1 fn)) 
  ) 
  (if L 
    (reverse L) 
  ) 
) 
 
;; list of strings to file, by append   -SCG- 12/00 
(defun L_FiLe_Append (L fn / e fh olderr) 
  (setq olderr *ERROR*) 
  (defun *error* (s) 
    (princ "\n ERR L_fiLe_append: ") 
    (princ s) 
    (if fh 
      (close fh) 
    ) 
    (princ) 
  ) 
  (if (setq Fh (open fn "a")) 
    (progn (foreach e L 
      (if (and e (str_P e)) 
        (write-Line e Fh) 
        (princ "\n L_fiLe_append, not-str. ") 
      ) 
    ) 
    (cLose fh) 
    ) 
  ) 
  (setq *error* olderr) 
  fn 
) 
 
;; Sort by Ascending X,  Vl_SortCar    
(defun sort_x (pL) 
  (vl-sort pL (function (lambda (x y) (> (car x) (car y))))) 
) 
;; Sort by Descending  Y 
(defun sort_>y (pL) 
  (vl-sort pL (function (lambda (x y) (> (cadr x) (cadr y))))) 
) 
 
;; special apss, in development: 
 
;; 9/16" Alternating PL Width, 
(defun c:9PL (/ rl) 
  (if (setq rl (PL_Vwd 0 (/ 9 16.0))) 
    (princ 
      (strcat "\n Segments: " (itoa (car rl)) ",  and done.") 
    ) 
    (princ "\n  9PL  NOT done   ") 
  ) 
  (princ) 
) 
;; 
 
;; 5/16"  Alternating PL Width, 
(defun c:5PL (/ rl) 
  (if (setq rl (PL_Vwd 0 (/ 5 16.0))) 
    (princ 
      (strcat "\n Segments: " (itoa (car rl)) ",  and done.") 
    ) 
    (princ "\n  9PL  NOT done   ") 
  ) 
  (princ) 
) 
;; 
 
;; 3/16" Alternating PL Width, 
(defun c:3PL (/ rl) 
  (if (setq rl (PL_Vwd 0 (/ 3 16.0))) 
    (princ 
      (strcat "\n Segments: " (itoa (car rl)) ",  and done.") 
    ) 
    (princ "\n  9PL  NOT done   ") 
  ) 
  (princ) 
) 
;; 
 
;; Variabl PL Width, return Segs, ename 
(defun PL_Vwd (W1 W2 / np Wf Q W pnp elas1 elas) 
  (setq Q -1 
 W W1 
 ;; start width #1 anyway 
 elas1 
  (entlast) 
  ) 
  ;; pnp  Wf are  nil to start, local var preserve Prev Next Pt, 
  (while (or (and pnp 
    (setq np (getpoint pnp 
         (strcat 
           "\n Next Point: " 
           (itoa (1+ Q)) 
           "  W: " 
           (rtos W 4 1) 
         ) 
      ) 
    ) 
      ) 
      (and (not pnp) 
    (setq np (getpoint (strcat 
           "\n Next Point: " 
           (itoa (1+ Q)) 
           "  W: " 
           (rtos W 4 1) 
         ) 
      ) 
    ) 
      ) 
  ) 
    (if (not pnp) 
      (command "pline") 
    ) 
    ;; 
    (command np 
      "w" 
      (if Wf 
        W2 
        W1 
      ) 
      (if Wf 
        W1 
        W2 
      ) 
    ) 
    (setq Wf  (not Wf) 
   Q   (1+ Q) 
   pnp np 
   W   (if Wf 
  W1 
  W2 
       ) 
    ) 
  ) 
  (IF pnp 
    (progn (COMMAND) 
    ;; or not created 
    (setq elas (entlast)) 
    (if (and elas (or (not elas1) (not (eq elas elas1)))) 
      (list Q elas) 
    ) 
    ) 
  ) 
  ;;  segs and name, nil if not   
) 
;;

st788796 · 发表于 2013-10-4 19:30:57

用 Google 搜索 Grdraw 时搜到的，看了看觉得某些函数还是很有特点顺手转贴了，不解释

ScmTools · 发表于 2013-10-4 21:52:09

支持一个，LZ一下贴出这么多，都看的有点眼花了{:soso_e147:}

dylc · 发表于 2013-10-5 14:54:15

有用，方便，谢谢楼主！

ngc · 发表于 2013-10-8 20:56:59

有些很常用的函数，难道是外国人写的，全英文的，;P，学习一下

xtdwynij · 发表于 2013-10-9 17:47:01

看不懂!文盲!

virage7676 · 发表于 2014-9-1 11:35:17

謝謝分享即刻下載增長見識

w379106181 · 发表于 2018-1-18 11:06:34

谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享

账号		自动登录	找回密码
密码			立即注册

[他山之石] Free Auto Lisp

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评

评分

相关帖子