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