home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 5.img / R11SUPP.EXE / 3D.LSP next >
Encoding:
Lisp/Scheme  |  1990-10-29  |  19.5 KB  |  622 lines
  1. ;;;--------------------------------------------------------------------------
  2. ;;; 3D.LSP
  3. ;;;  Copyright (C) 1990 by Autodesk, Inc.
  4. ;;;
  5. ;;;  THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. 
  6. ;;;  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF 
  7. ;;;  MERCHANTABILITY ARE HEREBY DISCLAIMED.
  8. ;;; 
  9. ;;; The user may initiate 3d.lsp by picking "3d objects" from the screen      
  10. ;;; menu, or by selecting the objects themselves from the "3d Construction"
  11. ;;; icon menu, or by loading it. Nine 3d objects can be drawn including 
  12. ;;; a box, cone, dish, dome, mesh, pyramid, sphere, torus, and wedge.
  13. ;;;
  14. ;;; When constructing a pyramid with the "ridge" option, enter the ridge
  15. ;;; points in the same direction as the base points, ridge point one being
  16. ;;; closest to base point one.  This will prevent the "bowtie" effect.
  17. ;;; Note that this is also true for the pyramid's "top" option.
  18. ;;;
  19. ;;; by Simon Jones - Autodesk UK Ltd.
  20. ;;; and Duff Kurland - Autodesk, Inc.
  21. ;;; November, 1986
  22. ;;;
  23. ;;; Combined into a single "3D" command - July 1987
  24. ;;;
  25. ;;; Changed functions to build shapes using the surface commands, and
  26. ;;; added box, wedge, pyramid, and mesh. - March 1988
  27. ;;;--------------------------------------------------------------------------
  28. ;;; Allow easier reloads
  29.  
  30. (setq boxwed     nil  
  31.       cone       nil
  32.       mesh       nil
  33.       pyramid    nil
  34.       spheres    nil
  35.       torus      nil
  36.       3derr      nil
  37.       C:3D       nil
  38. )
  39.  
  40. ;;;--------------------------------------------------------------------------
  41. ;;; System variable save
  42.  
  43. (defun modes (a)
  44.   (setq MLST nil)
  45.   (repeat (length a)
  46.     (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  47.     (setq a (cdr a))
  48.   )
  49. )
  50.  
  51. ;;;--------------------------------------------------------------------------
  52. ;;; System variable restore
  53.  
  54. (defun moder ()
  55.   (repeat (length MLST)
  56.     (setvar (caar MLST) (cadar MLST))
  57.     (setq MLST (cdr MLST))
  58.   )
  59. )
  60.  
  61. ;;;--------------------------------------------------------------------------
  62. ;;; Draw a cone
  63.  
  64. (defun cone (/ elev cen1 rad top h numseg cen2 oldelev e1 e2)
  65.   (setq numseg 0)
  66.   (initget 17)                        ;3D point can't be null
  67.   (setq elev (caddr (setq cen1 (getpoint "\nBase center point: "))))
  68.   (initget 7 "Diameter")              ;Base radius can't be 0, neg, or null
  69.   (setq rad (getdist cen1 "\nDiameter/<radius> of base: "))
  70.   (if (= rad "Diameter")
  71.     (progn
  72.       (initget 7)                     ;Base diameter can't be 0, neg, or null
  73.       (setq rad (/ (getdist cen1 "\nDiameter of base: ") 2.0))
  74.     )
  75.   )
  76.  
  77.   (initget 4 "Diameter")              ;Top radius can't be neg
  78.   (setq top (getdist cen1 "\nDiameter/<radius> of top <0>: "))
  79.   (if (= top "Diameter")
  80.     (progn
  81.       (initget 4)                     ;Top diameter can't be neg
  82.       (setq top (getdist cen1 "\nDiameter of top <0>: "))
  83.       (if top
  84.         (setq top (/ top 2.0))
  85.       )
  86.     )
  87.   )
  88.   (if (null top)
  89.     (setq top 0.0)
  90.   )
  91.   
  92.   (initget 7 "Height")                ;Height can't be 0, neg, or null
  93.   (setq h (getdist cen1 "\nHeight: "))
  94.  
  95.   (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
  96.     (initget 6)
  97.     (setq numseg (getint "\nNumber of segments <16>: "))
  98.     (if (null numseg)
  99.       (setq numseg 16)
  100.     )  
  101.     (if (< numseg 2)
  102.       (princ "\nNumber of segments must be greater than 1.")
  103.     )
  104.   )
  105.   (setvar "SURFTAB1" numseg)
  106.  
  107.   (command "CIRCLE" cen1 rad)         ;Draw base circle
  108.   (setq undoit T)
  109.   (setq e1 (entlast))
  110.   (setq cen2 (list (car cen1) (cadr cen1) (+ (caddr cen1) h)))
  111.   (setq oldelev (getvar "ELEVATION"))
  112.   (command "ELEV" (+ elev h) "")
  113.   (cond 
  114.     ;;Draw top point or circle
  115.     ((= top 0.0) (command "POINT" cen2))  
  116.     (t (command "CIRCLE" cen2 top))
  117.   )
  118.   (setq e2 (entlast))
  119.   (setvar "ELEVATION" oldelev)
  120.  
  121.   (command "RULESURF" (list e1 cen1) (list e2 cen2)) ;Draw cone
  122.   (entdel e1) 
  123.   (entdel e2)
  124. )
  125.  
  126. ;;;--------------------------------------------------------------------------
  127. ;;; Draw a sphere, dome, or dish
  128.  
  129. (defun spheres (typ / cen r numseg ax ax1 e1 e2)
  130.   (setq numseg 0)
  131.   (initget 17)                        ;3D point can't be null
  132.   (setq cen (getpoint (strcat "\nCenter of " typ": ")))
  133.   (initget 7 "Diameter")              ;Radius can't be 0, neg, or null
  134.   (setq r (getdist cen (strcat "\nDiameter/<radius>: ")))
  135.   (if (= r "Diameter")
  136.     (progn
  137.       (initget 7)                     ;Diameter can't be 0, neg, or null
  138.       (setq r (/ (getdist cen (strcat "\nDiameter: ")) 2.0))
  139.     )
  140.   )
  141.   (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
  142.         
  143.   (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
  144.     (initget 6)
  145.     (setq numseg (getint "\nNumber of longitudinal segments <16>: "))
  146.     (if (null numseg)
  147.       (setq numseg 16)
  148.     )
  149.     (if (< numseg 2)
  150.       (princ "\nNumber of segments must be greater than 1.")
  151.     )
  152.   )
  153.   (setvar "SURFTAB1" numseg)
  154.    
  155.   (setq numseg 0)
  156.   (while (< numseg 2)                 ;SURFTAB2 can't be less than 2
  157.     (initget 6)
  158.     (princ "\nNumber of latitudinal segments ") 
  159.     (if (= typ "sphere")
  160.       (princ "<16>: ")                ;Set default to 16 for a sphere
  161.       (princ "<8>: ")                 ;Set default to 8 for a dome or dish
  162.     )
  163.     (setq numseg (getint))
  164.     (if (null numseg)
  165.       (if (= typ "sphere")
  166.         (setq numseg 16)
  167.         (setq numseg 8)
  168.       )
  169.     )
  170.     (if (< numseg 2)
  171.       (princ "\nNumber of segments must be greater than 1.")
  172.     )
  173.   )
  174.   (setvar "SURFTAB2" numseg)
  175.  
  176.   (command "UCS" "x" "90")
  177.   (setq undoit T)
  178.  
  179.   (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  180.   (cond
  181.     ((= typ "sphere")
  182.       (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
  183.       (setq ax1 (list (car cen) (- (cadr cen) r) (caddr cen)))
  184.       (command "LINE" ax ax1 "")      ;Draw axis of revolution
  185.       (setq e1 (entlast))
  186.       ;;Draw path curve
  187.       (command "ARC" ax "e" ax1 "a" "180.0") 
  188.       (setq e2 (entlast))
  189.     )
  190.     (t
  191.       (if (= typ "dome")
  192.         (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
  193.         (setq ax (list (car cen) (- (cadr cen) r) (caddr cen)))
  194.       )
  195.       (command "LINE" cen ax "")      ;Draw axis of revolution
  196.       (setq e1 (entlast))
  197.       ;;Draw path curve
  198.       (command "ARC" "c" cen ax "a" "90.0") 
  199.       (setq e2 (entlast))
  200.     )
  201.   )
  202.  
  203.   ;;Draw dome or dish
  204.   (command "REVSURF" (list e2 ax) (list e1 cen) "" "") 
  205.   (entdel e1)                 
  206.   (entdel e2)
  207.   (command "UCS" "prev")
  208. )
  209.  
  210. ;;;--------------------------------------------------------------------------
  211. ;;; Draw a torus
  212.  
  213. (defun torus (/ cen l trad numseg hrad tcen ax e1 e2)
  214.   (setq numseg 0)
  215.   (initget 17)                        ;3D point can't be null
  216.   (setq cen (getpoint "\nCenter of torus: "))
  217.   (setq trad 0 l -1)
  218.   (while (> trad (/ l 2.0))
  219.     (initget 7 "Diameter")            ;Radius can't be 0, neg, or null
  220.     (setq l (getdist cen "\nDiameter/<radius> of torus: "))
  221.     (if (= l "Diameter")
  222.       (progn
  223.         (initget 7)                   ;Diameter can't be 0, neg, or null
  224.         (setq l (/ (getdist cen "\nDiameter: ") 2.0))
  225.       )
  226.     )
  227.     (initget 7 "Diameter")            ;Radius can't be 0, neg, or null
  228.     (setq trad (getdist cen "\nDiameter/<radius> of tube: "))
  229.     (if (= trad "Diameter")
  230.       (progn
  231.         (initget 7)
  232.         (setq trad (/ (getdist cen "\nDiameter: ") 2.0))
  233.       )
  234.     )
  235.     (if (> trad (/ l 2.0))
  236.       (prompt "\nTube diameter cannot exceed torus radius.")
  237.     )
  238.   )
  239.   (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
  240.  
  241.   (while (< numseg 2)
  242.     (initget 6)                       ;SURFTAB1 can't be 0 or neg
  243.     (setq numseg (getint "\nSegments around tube circumference <16>: "))
  244.     (if (null numseg)
  245.       (setq numseg 16)
  246.     )
  247.     (if (< numseg 2)
  248.       (princ "\nNumber of segments must be greater than 1.")
  249.     )
  250.   )
  251.   (setvar "SURFTAB1" numseg)
  252.  
  253.   (setq numseg 0)
  254.   (while (< numseg 2)
  255.     (initget 6)                       ;SURFTAB2 can't be 0 or neg
  256.     (setq numseg (getint "\nSegments around torus circumference <16>: "))
  257.     (if (null numseg)
  258.       (setq numseg 16)
  259.     )
  260.     (if (< numseg 2)
  261.       (princ "\nNumber of segments must be greater than 1.")
  262.     )
  263.   )
  264.   (setvar "SURFTAB2" numseg)
  265.  
  266.   (command "UCS" "x" "90")
  267.   (setq undoit T)
  268.  
  269.   (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  270.   (setq hrad (- l (* trad 2.0)))
  271.   (setq tcen (list (+ (+ (car cen) trad) hrad) (cadr cen) (caddr cen)))
  272.   (setq ax (list (car cen) (+ (cadr cen) 2.0) (caddr cen)))
  273.  
  274.   (command "CIRCLE" tcen trad)        ;Draw path curve
  275.   (setq e1 (entlast))
  276.   (command "LINE" cen ax "")          ;Draw axis of revolution
  277.   (setq e2 (entlast))
  278.   (command "REVSURF" (list e1 tcen) (list e2 ax) "" "") ;Draw torus
  279.   (entdel e1)            
  280.   (entdel e2)
  281.   (command "UCS" "prev")
  282. )
  283.  
  284. ;;;--------------------------------------------------------------------------
  285. ;;; Draw a box or wedge
  286.  
  287. (defun boxwed (typ / pt1 l w h1 h2 a ang pt2 pt3 pt4 pt5 pt6 pt7 pt8)
  288.   (initget 17)                        ;3D point can't be null
  289.   (setq pt1 (getpoint (strcat "\nCorner of "typ": ")))
  290.   (setvar "ORTHOMODE" 1)
  291.   (initget 7)                         ;Length can't be 0, neg, or null
  292.   (setq l (getdist pt1 "\nLength: "))
  293.   (setq pt3 (list (+ (car pt1) l) (cadr pt1) (caddr pt1)))
  294.   (grdraw pt1 pt3 2)
  295.   (cond 
  296.     ((= typ "wedge")
  297.       (initget 7)                     ;Width can't be 0, neg, or null
  298.       (setq w (getdist pt1 "\nWidth: "))
  299.     )
  300.     (t 
  301.       (initget 7 "Cube")              ;Width can't be 0, neg, or null
  302.       (setq w (getdist pt1 "\nCube/<Width>: "))
  303.       (if (= w "Cube") 
  304.          (setq w l h1 l h2 l)
  305.       )
  306.     )
  307.   )
  308.   (setq pt2 (list (car pt1) (+ (cadr pt1) w) (caddr pt1)))
  309.   (setq pt4 (list (car pt3) (+ (cadr pt3) w) (caddr pt3)))
  310.   (grdraw pt3 pt4 2)
  311.   (grdraw pt4 pt2 2)
  312.   (grdraw pt2 pt1 2)
  313.   (setvar "ORTHOMODE" 0)
  314.   (cond 
  315.     ((= typ "wedge")
  316.       (initget 7)                     ;Height can't be 0, neg, or null
  317.       (setq h1 (getdist pt1 "\nHeight: "))
  318.       (setq h2 0.0)
  319.     )
  320.     (t  
  321.       (if (/= h1 l) 
  322.         (progn
  323.           (initget 7)                 ;Height can't be 0, neg, or null
  324.           (setq h1 (getdist pt1 "\nHeight: "))
  325.           (setq h2 h1)
  326.         )
  327.       )
  328.     )
  329.   )
  330.  
  331.   (setq pt5 (list (car pt3) (cadr pt3) (+ (caddr pt3) h2)))
  332.   (setq pt6 (list (car pt4) (cadr pt4) (+ (caddr pt4) h2)))
  333.   (setq pt7 (list (car pt1) (cadr pt1) (+ (caddr pt1) h1)))
  334.   (setq pt8 (list (car pt2) (cadr pt2) (+ (caddr pt2) h1)))
  335.   (command "3DMESH" "6" "3" pt5 pt3 pt3 pt7 pt1 pt1 pt8 pt2
  336.             pt1 pt6 pt4 pt3 pt6 pt6 pt5 pt8 pt8 pt7
  337.   )            
  338.  
  339.   (setq undoit T)
  340.   (prompt "\nRotation angle about Z axis: ")
  341.   (command "rotate" (entlast) "" pt1 pause)
  342. )
  343.  
  344. ;;;--------------------------------------------------------------------------
  345. ;;; Draw a pyramid
  346.  
  347. (defun pyramid (/ pt1 pt2 pt3 pt4 pt5 tp1 tp2 tp3 tp4)
  348.   (initget 17)                        ;3D point can't be null
  349.   (setq pt1 (getpoint "\nFirst base point: "))
  350.   (initget 17)
  351.   (setq pt2 (getpoint pt1 "\nSecond base point: "))
  352.   (grdraw pt1 pt2 2)
  353.   (initget 17)
  354.   (setq pt3 (getpoint pt2 "\nThird base point: ")) 
  355.   (grdraw pt2 pt3 2)
  356.   (initget 17 "Tetrahedron")          ;Choose 3 or 4 point base
  357.   (setq pt4 (getpoint pt3 "\nTetrahedron/<Fourth base point>: ")) 
  358.   (if (= pt4 "Tetrahedron")
  359.     (grdraw pt3 pt1 2)
  360.     (progn
  361.       (grdraw pt3 pt4 2)
  362.       (grdraw pt4 pt1 2)
  363.     )
  364.   )
  365.   (cond 
  366.     ((= pt4 "Tetrahedron")            ;3 point may have top or apex
  367.       (initget 17 "Top")
  368.       (setq pt5 (getpoint "\nTop/<Apex point>: "))
  369.     )
  370.     (t                                ;4 point may have ridge, top, or apex
  371.       (initget 17 "Top Ridge") 
  372.       (setq pt5 (getpoint "\nRidge/Top/<Apex point>: "))
  373.     )
  374.   )
  375.   (cond 
  376.     ((= pt5 "Top")                    ;Prompt for top points
  377.       (initget 17)
  378.       (setq tp1 (getpoint pt1 "\nFirst top point: "))
  379.       (grdraw pt1 tp1 2)
  380.       (initget 17)
  381.       (setq tp2 (getpoint pt2 "\nSecond top point: "))
  382.       (grdraw tp1 tp2 2)
  383.       (grdraw pt2 tp2 2)
  384.       (initget 17)
  385.       (setq tp3 (getpoint pt3 "\nThird top point: "))
  386.       (grdraw tp2 tp3 2)
  387.       (grdraw pt3 tp3 2)
  388.       (if (/= pt4 "Tetrahedron")
  389.         (progn
  390.           (initget 17)
  391.           (setq tp4 (getpoint pt4 "\nFourth top point: "))
  392.           (grdraw tp3 tp4 2)
  393.           (grdraw pt4 tp4 2)
  394.         )
  395.       )
  396.     )
  397.     ((= pt5 "Ridge")                  ;Prompt for ridge points
  398.       (grdraw pt4 pt1 2 -1)
  399.       (initget 17)                
  400.       (setq tp1 (getpoint "\nFirst ridge point: "))
  401.       (grdraw pt4 pt1 2)
  402.       (grdraw pt1 tp1 2)
  403.       (grdraw pt4 tp1 2)
  404.       (grdraw pt3 pt2 2 -1)
  405.       (initget 17)                
  406.       (setq tp2 (getpoint tp1 "\nSecond ridge point: "))
  407.       (grdraw pt2 tp2 2)
  408.       (grdraw pt3 tp2 2)
  409.     )
  410.     (t 
  411.       (setq tp1 pt5)                  ;Must be apex
  412.       (setq tp2 tp1)
  413.     )
  414.   )
  415.  
  416.   (cond 
  417.     ((and (/= pt4 "Tetrahedron")(/= pt5 "Top"))
  418.       (command "3DMESH" "4" "4" tp1 tp1 tp2 tp2 tp1 pt4 pt3 tp2 
  419.                 tp1 pt1 pt2 tp2 tp1 tp1 tp2 tp2
  420.       )
  421.     )
  422.     ((and (/= pt4 "Tetrahedron")(= pt5 "Top"))
  423.       (command "3DMESH" "5" "4" tp1 tp1 tp2 tp2 tp4 tp4 tp3 tp3
  424.                 tp4 pt4 pt3 tp3 tp1 pt1 pt2 tp2 tp1 tp1 tp2 tp2
  425.       )
  426.     )
  427.     ((and (= pt4 "Tetrahedron")(/= pt5 "Top"))
  428.       (command "3DMESH" "5" "2" tp1 pt2 pt3 pt2 pt3 pt1 tp1 pt1 
  429.                 tp1 pt2
  430.       )
  431.     )
  432.     (t 
  433.       (command "3DMESH" "4" "4" pt3 pt1 tp1 tp3 pt2 pt2 tp2 tp2
  434.                 pt3 pt3 tp3 tp3 pt3 pt1 tp1 tp3
  435.       )
  436.     )
  437.   )     
  438. )
  439.  
  440. ;;;------------------------------------------------------------------------
  441. ;;; Draw a mesh
  442. ;;;
  443. ;;; Given a starting and an ending point, this function finds the next
  444. ;;; set of points in the N direction.
  445.  
  446. (defun next-n (pt1 pt2 / xinc yinc zinc loop pt)
  447.   (setq xinc (/ (- (car pt2) (car pt1)) (1- n)))
  448.   (setq yinc (/ (- (cadr pt2) (cadr pt1)) (1- n)))
  449.   (setq zinc (/ (- (caddr pt2) (caddr pt1)) (1- n)))
  450.   (setq loop (1- n))
  451.   (setq pt pt1)
  452.   (while (> loop 0)
  453.     (setq pt (list (+ (car pt) xinc) (+ (cadr pt) yinc) (+ (caddr pt) zinc)))
  454.     (command pt)
  455.     (setq loop (1- loop))
  456.   )
  457. )
  458.  
  459. ;;; This function finds the next point in the M direction.
  460.  
  461. (defun next-m (pt1 pt2 loop / xinc yinc zinc)
  462.   (if (/= m loop)
  463.     (progn
  464.       (setq xinc (/ (- (car pt2) (car pt1)) (- m loop)))
  465.       (setq yinc (/ (- (cadr pt2) (cadr pt1)) (- m loop)))
  466.       (setq zinc (/ (- (caddr pt2) (caddr pt1)) (- m loop)))
  467.     )
  468.     (progn
  469.       (setq xinc 0)
  470.       (setq yinc 0)
  471.       (setq zinc 0)
  472.     )
  473.   )
  474.   (setq pt1 (list (+ (car pt1) xinc) (+ (cadr pt1) yinc) (+ (caddr pt1) zinc)))
  475. )
  476.  
  477. (defun mesh (/ c1 c2 c3 c4 m n loop)
  478.   (setq m 0 n 0)                      ;Initialize variables
  479.   (initget 17)                     
  480.   (setq c1 (getpoint "\nFirst corner: "))
  481.   (initget 17)                     
  482.   (setq c2 (getpoint c1 "\nSecond corner: "))
  483.   (grdraw c1 c2 2)
  484.   (initget 17)                     
  485.   (setq c3 (getpoint c2 "\nThird corner: "))
  486.   (grdraw c2 c3 2)
  487.   (initget 17)                     
  488.   (setq c4 (getpoint c3 "\nFourth corner: "))
  489.   (grdraw c3 c4 2)
  490.   (grdraw c4 c1 2 1)
  491.   (while (or (< m 2) (> m 256))
  492.     (initget 7)                     
  493.     (setq m (getint "\nMesh M size: "))
  494.     (if (or (< m 2) (> m 256)) 
  495.       (princ "\nValue must be between 2 and 256.")
  496.     )
  497.   )
  498.   (grdraw c4 c1 2)
  499.   (grdraw c1 c2 2 1)
  500.   (while (or (< n 2) (> n 256))
  501.     (initget 7)                     
  502.     (setq n (getint "\nMesh N size: "))
  503.     (if (or (< n 2) (> n 256)) 
  504.       (princ "\nValue must be between 2 and 256.")
  505.     )
  506.   )
  507.   (setvar "osmode" 0)                 ;Turn OSMODE off
  508.   (setvar "blipmode" 0)               ;Turn BLIPMODE off
  509.   (command "3dmesh" m n)
  510.   (command c1)
  511.   (setq loop 1)
  512.   (next-n c1 c2)
  513.   (while (< loop m)
  514.     (setq c1 (next-m c1 c4 loop)) 
  515.     (setq c2 (next-m c2 c3 loop))
  516.     (command c1)
  517.     (next-n c1 c2)
  518.     (setq loop (1+ loop))
  519.   )
  520. )
  521.  
  522. ;;;--------------------------------------------------------------------------
  523. ;;; Internal error handler
  524.  
  525. (defun 3derr (s)                      ;If an error (such as CTRL-C) occurs
  526.                                       ;while this command is active...
  527.   (if (/= s "Function cancelled")
  528.     (princ (strcat "\nError: " s))
  529.   )
  530.   (if undoit
  531.     (progn
  532.       (command)
  533.       (command "UNDO" "e")            ;Terminate undo group
  534.       (princ "\nundoing...") 
  535.       (command "U")                   ;Erase partially drawn shape
  536.     )
  537.     (command "UNDO" "e")               
  538.   )
  539.   (moder)                             ;Restore saved modes
  540.   (if ofl
  541.     (setvar "FLATLAND" ofl)
  542.   )
  543.   (command "REDRAWALL")
  544.   (setvar "CMDECHO" oce)              ;Restore saved cmdecho value
  545.   (setq *error* olderr)               ;Restore old *error* handler
  546.   (princ)
  547. )
  548.  
  549. ;;;--------------------------------------------------------------------------
  550. ;;;
  551. ;;; Main program.  Draws 3D object specified by "key" argument.
  552. ;;; If "key" is nil, asks which object is desired.
  553.  
  554. (defun 3d (key / olderr)
  555.   (if m:err                           ;If called from the menu
  556.     (setq olderr m:err *error* 3derr) ;save the menus trapped *error*
  557.     (setq olderr *error* *error* 3derr)
  558.   )
  559.   (setq undoit nil ofl nil)
  560.   (setq oce (getvar "cmdecho"))
  561.   (setvar "CMDECHO" 0)
  562.   (modes '("BLIPMODE" "GRIDMODE" "ORTHOMODE" "OSMODE"
  563.            "SURFTAB1" "SURFTAB2" "UCSFOLLOW"))
  564.   ;Test for FLATLAND and FLATLAND's value.
  565.   (if (/= (setq ofl (getvar "FLATLAND")) 0) 
  566.     (setvar "FLATLAND" 0)             ;Set FLATLAND for duration
  567.   )                                   ;of the function.
  568.   (command "UNDO" "group")
  569.   (setvar "UCSFOLLOW" 0)
  570.   (setvar "GRIDMODE" 0)
  571.   (setvar "OSMODE" 0)
  572.   (if (null key)
  573.     (progn
  574.       (initget "Box Cone DIsh DOme Mesh Pyramid Sphere Torus Wedge")
  575.       (setq key (getkword 
  576.         "\nBox/Cone/DIsh/DOme/Mesh/Pyramid/Sphere/Torus/Wedge: "))
  577.     )
  578.   )
  579.   (cond 
  580.     ((= key "Box")     (boxwed  "box")   ) 
  581.     ((= key "Cone")    (cone)            )
  582.     ((= key "DIsh")    (spheres "dish")  )
  583.     ((= key "DOme")    (spheres "dome")  )
  584.     ((= key "Mesh")    (mesh)            )
  585.     ((= key "Pyramid") (pyramid)         )
  586.     ((= key "Sphere")  (spheres "sphere"))
  587.     ((= key "Torus")   (torus)           )
  588.     ((= key "Wedge")   (boxwed  "wedge") )
  589.     (T nil)                           ;Null reply?  Just exit
  590.   )
  591.   (moder)                             ;Restore saved modes
  592.   (if ofl
  593.     (setvar "FLATLAND" ofl)
  594.   )
  595.   (command "REDRAWALL")
  596.   (command "UNDO" "e")                ;Terminate undo group
  597.   (setvar "CMDECHO" oce)              ;Restore saved cmdecho value
  598.   (setq *error* olderr)               ;Restore old *error* handler
  599.   (princ)
  600. )
  601.  
  602. ;;;--------------------------------------------------------------------------
  603. ;;; C: function definitions
  604.  
  605. (defun C:BOX ()     (3d "Box"))
  606. (defun C:CONE ()    (3d "Cone"))
  607. (defun C:DISH ()    (3d "DIsh"))
  608. (defun C:DOME ()    (3d "DOme"))
  609. (defun C:MESH ()    (3d "Mesh"))
  610. (defun C:PYRAMID () (3d "Pyramid"))
  611. (defun C:SPHERE ()  (3d "Sphere"))
  612. (defun C:TORUS ()   (3d "Torus"))
  613. (defun C:WEDGE ()   (3d "Wedge"))
  614. (defun C:3D ()      (3d nil))
  615.  
  616. ;;; If loading this from LLoad, then print this string.  However, if we
  617. ;;; are loading from the menu, then load it silently.  I_LIST is set in
  618. ;;; the module that loads files in LLoad.lsp.
  619.  
  620. (if I_LIST (princ "\n\tC:3D loaded.  Start interactive command with 3D."))
  621. (if I_LIST (princ))
  622.