[编程交流] 污垢/土壤图案填充LISP

;/////////////////////////////////////////////////////////////////////////////////////////
;
(defun C:EARTH (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 SCL WID ANG)
 (setq PRP "EARTH")
 (setq WID 12)
 (setq SCL 12)
 (setq ANG 0)
 (setq CL01 (getpoint "\nSpecify first point: ")
       CL02 (getpoint CL01 "\nSpecify second point: ")
       RAD# (angle CL01 CL02)
       DEG# (RTD RAD#)
       DLEN (distance CL01 CL02)
       CL01 (trans CL01 1 0)
       CL02 (trans CL02 1 0)
       PT01 CL01
       PT02 (polar PT01 (DTR (+ DEG#   0)) DLEN)
       PT03 (polar PT01 (DTR (+ DEG# 270)) WID)
       PT04 (polar PT02 (DTR (+ DEG# 270)) WID))
 (command "._pline" PT01 PT02 PT04 PT03 "C")
 (setq E01 (entlast))
 (command "._-bhatch" "_a" "_a" "_y" "" "_p" PRP SCL ANG "_s" "_l" "" "")
 (command "._erase" E01 "")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
(defun DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
(defun RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;///////////////////////////////////////////////////////////////////////////////////////// 

;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
(defun C:EARTH (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 CPS SUS)
 (setq SUS_LST (list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits" "clayer"))
 (setq SUS (mapcar 'getvar SUS_LST))
 (setq TERR *error*)
 (setq *error* EARTH_ET)
 (or H:PRP (setq H:PRP "[color=red]EARTH[/color]"))      ;[color=red]Default Hatch Pattern[/color]
 (or H:WID (setq H:WID [color=red]6[/color]))            ;[color=red]Default Hatch Width[/color]
 (or H:SCL (setq H:SCL [color=red]6[/color]))            ;[color=red]Default Hatch Scale[/color]
 (or H:ANG (setq H:ANG [color=red]45[/color]))           ;[color=red]Default Hatch Angle[/color]
 (setq H:WID
   (cond
     ((getint (strcat "\nSpecify hatch width. <"(rtos H:WID 2 0)">: ")))(T H:WID)))
 (setq H:SCL
   (cond
     ((getint (strcat "\nSpecify hatch scale. <"(rtos H:SCL 2 0)">: ")))(T H:SCL)))
 (setq H:ANG
   (cond
     ((getint (strcat "\nSpecify hatch angle. <"(rtos H:ANG 2 0)">: ")))(T H:ANG)))
 (setq CL01 (getpoint "\nSpecify first point: ")
       CL02 (getpoint CL01 "\nSpecify second point: ")
       RAD# (angle CL01 CL02)
       DEG# (EARTH_RTD RAD#)
       DLEN (distance CL01 CL02)
       CL01 (trans CL01 1 0)
       CL02 (trans CL02 1 0)
       PT01 CL01
       PT02 (polar PT01 (EARTH_DTR (+ DEG#   0)) DLEN)
       PT03 (polar PT01 (EARTH_DTR (+ DEG# 270)) H:WID)
       PT04 (polar PT02 (EARTH_DTR (+ DEG# 270)) H:WID))
 (EARTH_CPS)
 (EARTH_ML "[color=red]HATCH[/color]" [color=red]1[/color] "[color=red]Continuous[/color]" [color=red]18[/color]) ;[color=red]Set layer name, color, linetype, & lineweight[/color]
 (setvar "clayer" "[color=red]HATCH[/color]")            ;[color=red]Set HATCH layer current[/color]
 (command "._pline" PT01 PT02 PT04 PT03 "C")
 (setq E01 (entlast))
 (command "._-bhatch" "_a" "_a" "_y" "" "_p" H:PRP H:SCL H:ANG "_s" "_l" "" "")
 (command "._erase" E01 "")
 (EARTH_RUS)
 (princ))
(princ)
(princ "\nEARTH.lsp loaded... Type EARTH to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun EARTH_DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun EARTH_RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun EARTH_ML (LNAM LCLR LTYP LWGT)
 (if (null (tblsearch "layer" LNAM))
   (entmake
     (list
       (cons   0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons   2  LNAM)
       (cons  70  0)
       (cons  62  LCLR)
       (cons   6  LTYP)
       (cons 290  1)
       (cons 370  LWGT))))
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun EARTH_CPS ()
 (setq CPS (list 0 1 0 0 0 0))
 (mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
 (princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun EARTH_RUS ()
 (setq *error* TERR)
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has completed successfully and will now restore your settings.")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun EARTH_ET (ERRORMSG)
 (command nil nil nil)
 (if (not (member ERRORMSG '("console break" "Function cancelled")))
   (princ (strcat "\nError:" ERRORMSG)))
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has encountered a user error!")
 (princ "\nProgram will now restore your settings and exit.")
 (terpri)
 (setq *error* TERR)
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////