3d.lsp

Autocad-2005-简体中文-解密版.zip

; Next available MSG number is    76 
; MODULE_ID LSP_3D_LSP_
;;;
;;;    3d.lsp
;;;    
;;;    Copyright 1988,1990,1992,1994,1996-2003 by Autodesk, Inc.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii) 
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;============================================================================
;;;
;;; Nine 3d objects can be drawn: box, cone, dish, dome, mesh, pyramid,
;;; sphere, torus, and wedge.
;;;
;;; When constructing a pyramid with the "ridge" option, enter the ridge
;;; points in the same direction as the base points, ridge point one being
;;; closest to base point one.  This will prevent the "bowtie" effect.
;;; Note that this is also true for the pyramid's "top" option.


;;; ===================== load-time error checking ============================

  (defun ai_abort (app msg)
     (defun *error* (s)
        (if old_error (setq *error* old_error))
        (princ)
     )
     (if msg
       (alert (strcat " Application error: "
                      app
                      " \n\n  "
                      msg
                      "  \n"
              )
       )
     )
     (exit)
  )

;;; Check to see if AI_UTILS is loaded, If not, try to find it,
;;; and then try to load it.
;;;
;;; If it can't be found or it can't be loaded, then abort the
;;; loading of this file immediately, preserving the (autoload)
;;; stub function.

  (cond
    ; it's already loaded.
    ((and ai_dcl (listp ai_dcl)))
    ; find it
    ((not (findfile "ai_utils.lsp"))
      (ai_abort "3D"
                  (strcat "Can't locate file AI_UTILS.LSP."
                          "\n Check support directory." ) ) )
    ; load it
    ((eq "failed" (load "ai_utils" "failed"))
        (ai_abort "3D" "Can't load file AI_UTILS.LSP") )
  )

  ; defined in AI_UTILS.LSP
  (if (not (ai_acadapp))
    ; a Nil <msg> supresses ai_abort's alert box dialog.
    (ai_abort "3D" nil)
  )

;;; ==================== end load-time operations ===========================



;;;--------------------------------------------------------------------------
;;; Allow easier reloads

(setq boxwed     nil  
      cone       nil
      mesh       nil
      pyramid    nil
      spheres    nil
      torus      nil
      3derr      nil
      C:3D       nil
)

;;;--------------------------------------------------------------------------
;;; System variable save

(defun modes (a)
  (setq MLST nil)
  (repeat (length a)
    (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
    (setq a (cdr a))
  )
)

;;;--------------------------------------------------------------------------
;;; System variable restore

(defun moder ()
  (repeat (length MLST)
    (setvar (caar MLST) (cadar MLST))
    (setq MLST (cdr MLST))
  )
)

;;;--------------------------------------------------------------------------
;;; Draw a cone

(defun cone (/ elev cen1 rad top h numseg cen2 oldelev e1 e2)
  (setq numseg 0)
  ;3D point can't be null
  (initget 17)
  (setq elev (caddr (setq cen1 (getpoint "\nSpecify center point for base of cone: "))))
  ;Base radius can't be 0, neg, or null
  (initget 7 "Diameter")
  (setq rad (getdist cen1 "\nSpecify radius for base of cone or [Diameter]: "))
  (if (= rad "Diameter")
    (progn
      ;Base diameter can't be 0, neg, or null
      (initget 7)
      (setq rad (/ (getdist cen1 "\nSpecify diameter for base of cone: ") 2.0))
    )
  )

  ;Top radius can't be neg
  (initget 4 "Diameter")
  (setq top (getdist cen1 "\nSpecify radius for top of cone or [Diameter] <0>: "))
  (if (= top "Diameter")
    (progn
      ;Top diameter can't be neg
      (initget 4)
      (setq top (getdist cen1 "\nSpecify diameter for top of cone <0>: "))
      (if top
        (setq top (/ top 2.0))
      )
    )
  )
  (if (null top)
    (setq top 0.0)
  )

  ;Height can't be 0, neg, or null
  (initget 7 "Height")
  (setq h (getdist cen1 "\nSpecify height of cone: "))

  ;SURFTAB1 can't be less than 2
  (while (< numseg 2)
    (initget 6)
    (setq numseg (getint "\nEnter number of segments for surface of cone <16>: "))
    (if (null numseg)
      (setq numseg 16)
    )  
    (if (< numseg 2)
      (princ "\nNumber of segments must be greater than 1.")
    )
  )
  (setvar "SURFTAB1" numseg)

  ; Draw base circle
  (command "_.CIRCLE" cen1 rad)
  (setq undoit T)
  (setq e1 (entlast))
  (setq cen2 (list (car cen1) (cadr cen1) (+ (caddr cen1) h)))
  (setq oldelev (getvar "ELEVATION"))
  (command "_.ELEV" (+ elev h) "")
  (cond 
    ; Draw top point or circle
    ((= top 0.0) (command "_.POINT" cen2))  
    (t (command "_.CIRCLE" cen2 top))
  )
  (setq e2 (entlast))
  (setvar "ELEVATION" oldelev)

  ; Draw cone
  (command "_.RULESURF" (list e1 cen1) (list e2 cen2))
  (entdel e1) 
  (entdel e2)
)

;;;--------------------------------------------------------------------------
;;; Draw a sphere, dome, or dish

(defun spheres (typ / cen r numseg ax ax1 e1 e2)
  (setq numseg 0)
  (initget 17)                        ;3D point can't be null
  (setq cen (getpoint (strcat "\nSpecify center point of " typ": ")))
  (initget 7 "Diameter")              ;Radius can't be 0, neg, or null
  (cond 
    ((= typ "sphere") (princ "\nSpecify radius of sphere or [Diameter]: "))
    ((= typ "dome"  ) (princ "\nSpecify radius of dome or [Diameter]: "))
    ((= typ "dish"  ) (princ "\nSpecify radius of dish or [Diameter]: "))
  )
  (setq r (getdist cen )) 
  (if (= r "Diameter")
    (progn
      (initget 7)                     ;Diameter can't be 0, neg, or null
      (setq r (/ (getdist cen (strcat "\nSpecify diameter of "typ": ")) 2.0))
    )
  )
  (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
        
  (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
    (initget 6)
	(princ (strcat "\nEnter number of longitudinal segments for surface of "typ" <16>: "))
    (setq numseg (getint))
    (if (null numseg)
      (setq numseg 16)
    )
    (if (< numseg 2)
      (princ "\nNumber of segments must be greater than 1.")
    )
  )
  (setvar "SURFTAB1" numseg)
   
  (setq numseg 0)
  (while (< numseg 2)                 ;SURFTAB2 can't be less than 2
    (initget 6)
    (princ (strcat "\nEnter number of latitudinal segments for surface of "typ" "))
    (if (= typ "sphere")
      (princ "<16>: ")                ;Set default to 16 for a sphere
      (princ "<8>: ")                 ;Set default to 8 for a dome or dish
    )
    (setq numseg (getint))
    (if (null numseg)
      (if (= typ "sphere")
        (setq numseg 16)
        (setq numseg 8)
      )
    )
    (if (< numseg 2)
      (princ "\nNumber of segments must be greater than 1.")
    )
  )
  (setvar "SURFTAB2" numseg)

  (command "_.UCS" "_x" "90")
  (setq undoit T)

  (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  (cond
    ((= typ "sphere")
      (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
      (setq ax1 (list (car cen) (- (cadr cen) r) (caddr cen)))
      (command "_.LINE" ax ax1 "")      ;Draw axis of revolution
      (setq e1 (entlast))
      ;;Draw path curve
      (command "_.ARC" ax "_e" ax1 "_a" "180.0") 
      (setq e2 (entlast))
    )
    (t
      (if (= typ "dome")
        (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
        (setq ax (list (car cen) (- (cadr cen) r) (caddr cen)))
      )
      (command "_.LINE" cen ax "")      ;Draw axis of revolution
      (setq e1 (entlast))
      ;;Draw path curve
      (command "_.ARC" "_c" cen ax "_a" "90.0") 
      (setq e2 (entlast))
    )
  )

  ;;Draw dome or dish
  (command "_.REVSURF" (list e2 ax) (list e1 cen) "" "") 
  (entdel e1)                 
  (entdel e2)
  (command "_.UCS" "_prev")
)

;;;--------------------------------------------------------------------------
;;; Draw a torus

(defun torus (/ cen l trad numseg hrad tcen ax e1 e2)
  (setq numseg 0)
  (initget 17)                        ;3D point can't be null
  (setq cen (getpoint "\nSpecify center point of torus: "))
  (setq trad 0 l -1)
  (while (> trad (/ l 2.0))
    (initget 7 "Diameter")            ;Radius can't be 0, neg, or null
    (setq l (getdist cen "\nSpecify radius of torus or [Diameter]: "))
    (if (= l "Diameter")
      (progn
        (initget 7)                   ;Diameter can't be 0, neg, or null
        (setq l (/ (getdist cen "\nSpecify diameter of torus: ") 2.0))
      )
    )
    (initget 7 "Diameter")            ;Radius can't be 0, neg, or null
    (setq trad (getdist cen "\nSpecify radius of tube or [Diameter]: "))
    (if (= trad "Diameter")
      (progn
        (initget 7)
        (setq trad (/ (getdist cen "\nSpecify diameter of tube: ") 2.0))
      )
    )
    (if (> trad (/ l 2.0))
      (prompt "\nTube diameter cannot exceed torus radius.")
    )
  )
  (setq cen (trans cen 1 0))          ;Translate from UCS to WCS

  (while (< numseg 2)
    (initget 6)                       ;SURFTAB1 can't be 0 or neg
    (setq numseg (getint "\nEnter number of segments around tube circumference <16>: "))
    (if (null numseg)
      (setq numseg 16)
    )
    (if (< numseg 2)
      (princ "\nNumber of segments must be greater than 1.")
    )
  )
  (setvar "SURFTAB1" numseg)

  (setq numseg 0)
  (while (< numseg 2)
    (initget 6)                       ;SURFTAB2 can't be 0 or neg
    (setq numseg (getint "\nEnter number of segments around torus circumference <16>: "))
    (if (null numseg)
      (setq numseg 16)
    )
    (if (< numseg 2)
      (princ "\nNumber of segments must be greater than 1.")
    )
  )
  (setvar "SURFTAB2" numseg)

  (command "_.UCS" "_x" "90")
  (setq undoit T)

  (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  (setq hrad (- l (* trad 2.0)))
  (setq tcen (list (+ (+ (car cen) trad) hrad) (cadr cen) (caddr cen)))
  (setq ax (list (car cen) (+ (cadr cen) 2.0) (caddr cen)))

  (command "_.CIRCLE" tcen trad)        ;Draw path curve
  (setq e1 (entlast))
  (command "_.LINE" cen ax "")          ;Draw axis of revolution
  (setq e2 (entlast))
  (command "_.REVSURF" (list e1 tcen) (list e2 ax) "" "") ;Draw torus
  (entdel e1)            
  (entdel e2)
  (command "_.UCS" "_prev")
)

;;;--------------------------------------------------------------------------
;;; Draw a box or wedge

(defun boxwed (typ / pt1 l w h1 h2 a ang pt2 pt3 pt4 pt5 pt6 pt7 pt8 lockflag)
  (initget 17)                        ;3D point can't be null
  (setq pt1 (getpoint (strcat "\nSpecify corner point of "typ": ")))
  (setvar "ORTHOMODE" 1)
  (initget 7)                         ;Length can't be 0, neg, or null