home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 4.img / SUPPORT1.LIB / 3D.LSP next >
Encoding:
Text File  |  1993-02-09  |  20.4 KB  |  671 lines
  1. ;;;--------------------------------------------------------------------------
  2. ;;;   3D.LSP
  3. ;;;   ¬⌐┼v⌐╥ª│ (C) 1990-1992  Autodesk ñ╜Ñq
  4. ;;;
  5. ;;;   Ñ╗│n┼ΘºK╢O¿╤▒z╢iªµÑ⌠ª≤Ñ╬│~╗▌¿D¬║½■¿⌐íB¡╫º∩ñ╬╡oªµ, ª²¼O░╚╜╨┐φ┤`ñU¡z
  6. ;;;   ¡∞½h :
  7. ;;;
  8. ;;;   1)  ñWªC¬║¬⌐┼v│qºi░╚╗▌ÑX▓{ªb¿Cñ@Ñ≈½■¿⌐∙╪íC
  9. ;;;   2)  ¼█├÷¬║╗í⌐·ñσÑ≤ñ]Ñ▓╢╖⌐·╕ⁿ¬⌐┼v│qºiñ╬Ñ╗╢╡│\Ñi│qºiíC
  10. ;;;
  11. ;;;   Ñ╗│n┼Θ╢╚┤ú¿╤º@¼░└│Ñ╬ñW¬║░╤ª╥, ª╙Ñ╝┴n⌐·⌐╬┴⌠ºtÑ⌠ª≤½O├╥; ╣∩⌐≤Ñ⌠ª≤»S«φ
  12. ;;;   Ñ╬│~ñº╛A║┘⌐╩, ÑHñ╬░╙╖~╛P░Γ⌐╥┴⌠ºtÑX¿π¬║½O├╥, ªbª╣ñ@╖ºñ⌐ÑHº_╗{íC
  13. ;;;
  14. ;;; The user may initiate 3d.lsp by picking "3d objects" from the screen
  15. ;;; menu, or by selecting the objects themselves from the "3d Construction"
  16. ;;; icon menu, or by loading it. Nine 3d objects can be drawn including
  17. ;;; a box, cone, dish, dome, mesh, pyramid, sphere, torus, and wedge.
  18. ;;;
  19. ;;; When constructing a pyramid with the "ridge" option, enter the ridge
  20. ;;; points in the same direction as the base points, ridge point one being
  21. ;;; closest to base point one.  This will prevent the "bowtie" effect.
  22. ;;; Note that this is also true for the pyramid's "top" option.
  23. ;;;
  24. ;;;
  25. ;;; ===========================================================================
  26. ;;; ===================== load-time error checking ============================
  27. ;;;
  28.  
  29.   (defun ai_abort (app msg)
  30.      (defun *error* (s)
  31.         (if old_error (setq *error* old_error))
  32.         (princ)
  33.      )
  34.      (if msg
  35.        (alert (strcat " Application error: "
  36.                       app
  37.                       " \n\n  "
  38.                       msg
  39.                       "  \n"
  40.               )
  41.        )
  42.      )
  43.      (exit)
  44.   )
  45.  
  46. ;;; Check to see if AI_UTILS is loaded, If not, try to find it,
  47. ;;; and then try to load it.
  48. ;;;
  49. ;;; If it can't be found or it can't be loaded, then abort the
  50. ;;; loading of this file immediately, preserving the (autoload)
  51. ;;; stub function.
  52.  
  53.   (cond
  54.      (  (and ai_dcl (listp ai_dcl)))          ; it's already loaded.
  55.  
  56.      (  (not (findfile "ai_utils.lsp"))                     ; find it
  57.         (ai_abort "3D"
  58.                   (strcat "Can't locate file AI_UTILS.LSP."
  59.                           "\n Check support directory.")))
  60.  
  61.      (  (eq "failed" (load "ai_utils" "failed"))            ; load it
  62.         (ai_abort "3D" "Can't load file AI_UTILS.LSP"))
  63.   )
  64.  
  65.   (if (not (ai_acadapp))               ; defined in AI_UTILS.LSP
  66.       (ai_abort "3D" nil)         ; a Nil <msg> supresses
  67.   )                                    ; ai_abort's alert box dialog.
  68.  
  69. ;;; ==================== end load-time operations ===========================
  70.  
  71.  
  72.  
  73. ;;;--------------------------------------------------------------------------
  74. ;;; Allow easier reloads
  75.  
  76. (setq boxwed     nil
  77.       cone       nil
  78.       mesh       nil
  79.       pyramid    nil
  80.       spheres    nil
  81.       torus      nil
  82.       3derr      nil
  83.       C:3D       nil
  84. )
  85.  
  86. ;;;--------------------------------------------------------------------------
  87. ;;; System variable save
  88.  
  89. (defun modes (a)
  90.   (setq MLST nil)
  91.   (repeat (length a)
  92.     (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  93.     (setq a (cdr a))
  94.   )
  95. )
  96.  
  97. ;;;--------------------------------------------------------------------------
  98. ;;; System variable restore
  99.  
  100. (defun moder ()
  101.   (repeat (length MLST)
  102.     (setvar (caar MLST) (cadar MLST))
  103.     (setq MLST (cdr MLST))
  104.   )
  105. )
  106.  
  107. ;;;--------------------------------------------------------------------------
  108. ;;; Draw a cone
  109.  
  110. (defun cone (/ elev cen1 rad top h numseg cen2 oldelev e1 e2)
  111.   (setq numseg 0)
  112.   (initget 17)                        ;3D point can't be null
  113.   (setq elev (caddr (setq cen1 (getpoint "\n░≥⌐│íuñññ▀┬Iív: "))))
  114.   (initget 7 "Diameter")              ;Base radius can't be 0, neg, or null
  115.   (setq rad (getdist cen1 "\n░≥⌐│í╨D¬╜«|/<Ñb«|>: "))
  116.   (if (= rad "Diameter")
  117.     (progn
  118.       (initget 7)                     ;Base diameter can't be 0, neg, or null
  119.       (setq rad (/ (getdist cen1 "\n░≥⌐│¬╜«|: ") 2.0))
  120.     )
  121.   )
  122.  
  123.   (initget 4 "Diameter")              ;Top radius can't be neg
  124.   (setq top (getdist cen1 "\n│╗│íí╨D¬╜«|/<Ñb«|> <0>: "))
  125.   (if (= top "Diameter")
  126.     (progn
  127.       (initget 4)                     ;Top diameter can't be neg
  128.       (setq top (getdist cen1 "\n│╗│í¬╜«| <0>: "))
  129.       (if top
  130.         (setq top (/ top 2.0))
  131.       )
  132.     )
  133.   )
  134.   (if (null top)
  135.     (setq top 0.0)
  136.   )
  137.  
  138.   (initget 7 "Height")                ;Height can't be 0, neg, or null
  139.   (setq h (getdist cen1 "\n░¬½╫: "))
  140.  
  141.   (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
  142.     (initget 6)
  143.     (setq numseg (getint "\n║c¡▒╝╞╢q <16>: "))
  144.     (if (null numseg)
  145.       (setq numseg 16)
  146.     )
  147.     (if (< numseg 2)
  148.       (princ "\n║c¡▒╝╞╢qÑ▓╢╖ > 1 íC")
  149.     )
  150.   )
  151.   (setvar "SURFTAB1" numseg)
  152.  
  153.   (command "_.CIRCLE" cen1 rad)         ;Draw base circle
  154.   (setq undoit T)
  155.   (setq e1 (entlast))
  156.   (setq cen2 (list (car cen1) (cadr cen1) (+ (caddr cen1) h)))
  157.   (setq oldelev (getvar "ELEVATION"))
  158.   (command "_.ELEV" (+ elev h) "")
  159.   (cond
  160.     ;;Draw top point or circle
  161.     ((= top 0.0) (command "_.POINT" cen2))
  162.     (t (command "_.CIRCLE" cen2 top))
  163.   )
  164.   (setq e2 (entlast))
  165.   (setvar "ELEVATION" oldelev)
  166.  
  167.   (command "_.RULESURF" (list e1 cen1) (list e2 cen2)) ;Draw cone
  168.   (entdel e1)
  169.   (entdel e2)
  170. )
  171.  
  172. ;;;--------------------------------------------------------------------------
  173. ;;; Draw a sphere, dome, or dish
  174.  
  175. (defun spheres (typ / cen r numseg ax ax1 e1 e2)
  176.   (setq numseg 0)
  177.   (initget 17)                        ;3D point can't be null
  178.   (setq cen (getpoint (strcat "\n" typ "íuñññ▀┬Iív: ")))
  179.   (initget 7 "Diameter")              ;Radius can't be 0, neg, or null
  180.   (setq r (getdist cen (strcat "\nD¬╜«|/<Ñb«|>: ")))
  181.   (if (= r "Diameter")
  182.     (progn
  183.       (initget 7)                     ;Diameter can't be 0, neg, or null
  184.       (setq r (/ (getdist cen (strcat "\nD¬╜«|: ")) 2.0))
  185.     )
  186.   )
  187.   (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
  188.  
  189.   (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
  190.     (initget 6)
  191.     (setq numseg (getint "\n╕g╜u (┴aªV) ║c¡▒╝╞╢q <16>: "))
  192.     (if (null numseg)
  193.       (setq numseg 16)
  194.     )
  195.     (if (< numseg 2)
  196.       (princ "\níu║c¡▒╝╞╢qívÑ▓╢╖ > 1 íC")
  197.     )
  198.   )
  199.   (setvar "SURFTAB1" numseg)
  200.  
  201.   (setq numseg 0)
  202.   (while (< numseg 2)                 ;SURFTAB2 can't be less than 2
  203.     (initget 6)
  204.     (princ "\n╜n╜u (╛εªV) ║c¡▒╝╞╢q ")
  205.     (if (= typ "╢Ω▓y¡▒║c")
  206.       (princ "<16>: ")                ;Set default to 16 for a sphere
  207.       (princ "<8>: ")                 ;Set default to 8 for a dome or dish
  208.     )
  209.     (setq numseg (getint))
  210.     (if (null numseg)
  211.       (if (= typ "╢Ω▓y¡▒║c")
  212.         (setq numseg 16)
  213.         (setq numseg 8)
  214.       )
  215.     )
  216.     (if (< numseg 2)
  217.       (princ "\níu║c¡▒╝╞╢qívÑ▓╢╖ > 1 íC")
  218.     )
  219.   )
  220.   (setvar "SURFTAB2" numseg)
  221.  
  222.   (command "_.UCS" "_x" "90")
  223.   (setq undoit T)
  224.  
  225.   (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  226.   (cond
  227.     ((= typ "╢Ω▓y¡▒║c")
  228.       (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
  229.       (setq ax1 (list (car cen) (- (cadr cen) r) (caddr cen)))
  230.       (command "_.LINE" ax ax1 "")      ;Draw axis of revolution
  231.       (setq e1 (entlast))
  232.       ;;Draw path curve
  233.       (command "_.ARC" ax "_e" ax1 "_a" "180.0")
  234.       (setq e2 (entlast))
  235.     )
  236.     (t
  237.       (if (= typ "ñW▓y¡▒║c")
  238.         (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
  239.         (setq ax (list (car cen) (- (cadr cen) r) (caddr cen)))
  240.       )
  241.       (command "_.LINE" cen ax "")      ;Draw axis of revolution
  242.       (setq e1 (entlast))
  243.       ;;Draw path curve
  244.       (command "_.ARC" "_c" cen ax "_a" "90.0")
  245.       (setq e2 (entlast))
  246.     )
  247.   )
  248.  
  249.   ;;Draw dome or dish
  250.   (command "_.REVSURF" (list e2 ax) (list e1 cen) "" "")
  251.   (entdel e1)
  252.   (entdel e2)
  253.   (command "_.UCS" "_prev")
  254. )
  255.  
  256. ;;;--------------------------------------------------------------------------
  257. ;;; Draw a torus
  258.  
  259. (defun torus (/ cen l trad numseg hrad tcen ax e1 e2)
  260.   (setq numseg 0)
  261.   (initget 17)                        ;3D point can't be null
  262.   (setq cen (getpoint "\n└⌠¼Wíuñññ▀┬Iív: "))
  263.   (setq trad 0 l -1)
  264.   (while (> trad (/ l 2.0))
  265.     (initget 7 "Diameter")            ;Radius can't be 0, neg, or null
  266.     (setq l (getdist cen "\n└⌠¼Wí╨D¬╜«|/<Ñb«|> : "))
  267.     (if (= l "Diameter")
  268.       (progn
  269.         (initget 7)                   ;Diameter can't be 0, neg, or null
  270.         (setq l (/ (getdist cen "\nD¬╜«|: ") 2.0))
  271.       )
  272.     )
  273.     (initget 7 "Diameter")            ;Radius can't be 0, neg, or null
  274.     (setq trad (getdist cen "\n║▐¼Wí╨D¬╜«|/<Ñb«|> : "))
  275.     (if (= trad "Diameter")
  276.       (progn
  277.         (initget 7)
  278.         (setq trad (/ (getdist cen "\n¬╜«|: ") 2.0))
  279.       )
  280.     )
  281.     (if (> trad (/ l 2.0))
  282.       (prompt "\níu║▐¼W¬╜«|ívñúÑi╢W╣Líu└⌠¼WÑb«|ívíC")
  283.     )
  284.   )
  285.   (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
  286.  
  287.   (while (< numseg 2)
  288.     (initget 6)                       ;SURFTAB1 can't be 0 or neg
  289.     (setq numseg (getint "\n│≥┬╢íu║▐¼Wív¬║║c¡▒╝╞╢q <16>: "))
  290.     (if (null numseg)
  291.       (setq numseg 16)
  292.     )
  293.     (if (< numseg 2)
  294.       (princ "\níu║c¡▒╝╞╢qívÑ▓╢╖> 1 íC")
  295.     )
  296.   )
  297.   (setvar "SURFTAB1" numseg)
  298.  
  299.   (setq numseg 0)
  300.   (while (< numseg 2)
  301.     (initget 6)                       ;SURFTAB2 can't be 0 or neg
  302.     (setq numseg (getint "\n│≥┬╢íu└⌠¼Wív¬║║c¡▒╝╞╢q <16>: "))
  303.     (if (null numseg)
  304.       (setq numseg 16)
  305.     )
  306.     (if (< numseg 2)
  307.       (princ "\níu║c¡▒╝╞╢qívÑ▓╢╖ > 1 íC")
  308.     )
  309.   )
  310.   (setvar "SURFTAB2" numseg)
  311.  
  312.   (command "_.UCS" "_x" "90")
  313.   (setq undoit T)
  314.  
  315.   (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  316.   (setq hrad (- l (* trad 2.0)))
  317.   (setq tcen (list (+ (+ (car cen) trad) hrad) (cadr cen) (caddr cen)))
  318.   (setq ax (list (car cen) (+ (cadr cen) 2.0) (caddr cen)))
  319.  
  320.   (command "_.CIRCLE" tcen trad)        ;Draw path curve
  321.   (setq e1 (entlast))
  322.   (command "_.LINE" cen ax "")          ;Draw axis of revolution
  323.   (setq e2 (entlast))
  324.   (command "_.REVSURF" (list e1 tcen) (list e2 ax) "" "") ;Draw torus
  325.   (entdel e1)
  326.   (entdel e2)
  327.   (command "_.UCS" "_prev")
  328. )
  329.  
  330. ;;;--------------------------------------------------------------------------
  331. ;;; Draw a box or wedge
  332.  
  333. (defun boxwed (typ / pt1 l w h1 h2 a ang pt2 pt3 pt4 pt5 pt6 pt7 pt8)
  334.   (initget 17)                        ;3D point can't be null
  335.   (setq pt1 (getpoint (strcat "\n" typ "íu¿ñ┬Iív: ")))
  336.   (setvar "ORTHOMODE" 1)
  337.   (initget 7)                         ;Length can't be 0, neg, or null
  338.   (setq l (getdist pt1 "\n¬°½╫: "))
  339.   (setq pt3 (list (+ (car pt1) l) (cadr pt1) (caddr pt1)))
  340.   (grdraw pt1 pt3 2)
  341.   (cond
  342.     ((= typ "╖ñº╬¡▒║c")
  343.       (initget 7)                     ;Width can't be 0, neg, or null
  344.       (setq w (getdist pt1 "\n╝e½╫: "))
  345.     )
  346.     (t
  347.       (initget 7 "Cube")              ;Width can't be 0, neg, or null
  348.       (setq w (getdist pt1 "\nCÑ┐Ñ▀ñΦ¡▒║c/<╝e½╫>: "))
  349.       (if (= w "Cube")
  350.          (setq w l h1 l h2 l)
  351.       )
  352.     )
  353.   )
  354.   (setq pt2 (list (car pt1) (+ (cadr pt1) w) (caddr pt1)))
  355.   (setq pt4 (list (car pt3) (+ (cadr pt3) w) (caddr pt3)))
  356.   (grdraw pt3 pt4 2)
  357.   (grdraw pt4 pt2 2)
  358.   (grdraw pt2 pt1 2)
  359.   (setvar "ORTHOMODE" 0)
  360.   (cond
  361.     ((= typ "╖ñº╬¡▒║c")
  362.       (initget 7)                     ;Height can't be 0, neg, or null
  363.       (setq h1 (getdist pt1 "\n░¬½╫: "))
  364.       (setq h2 0.0)
  365.     )
  366.     (t
  367.       (if (/= h1 l)
  368.         (progn
  369.           (initget 7)                 ;Height can't be 0, neg, or null
  370.           (setq h1 (getdist pt1 "\n░¬½╫: "))
  371.           (setq h2 h1)
  372.         )
  373.       )
  374.     )
  375.   )
  376.  
  377.   (setq pt5 (list (car pt3) (cadr pt3) (+ (caddr pt3) h2)))
  378.   (setq pt6 (list (car pt4) (cadr pt4) (+ (caddr pt4) h2)))
  379.   (setq pt7 (list (car pt1) (cadr pt1) (+ (caddr pt1) h1)))
  380.   (setq pt8 (list (car pt2) (cadr pt2) (+ (caddr pt2) h1)))
  381.   (command "_.3DMESH" "6" "3" pt5 pt3 pt3 pt7 pt1 pt1 pt8 pt2
  382.             pt1 pt6 pt4 pt3 pt6 pt6 pt5 pt8 pt8 pt7
  383.   )
  384.  
  385.   (setq undoit T)
  386.   (prompt "\n┬╢ Z ╢bíu▒█┬α¿ñív: ")
  387.   (command "_.ROTATE" (entlast) "" pt1 pause)
  388. )
  389.  
  390. ;;;--------------------------------------------------------------------------
  391. ;;; Draw a pyramid
  392.  
  393. (defun pyramid (/ pt1 pt2 pt3 pt4 pt5 tp1 tp2 tp3 tp4)
  394.   (initget 17)                        ;3D point can't be null
  395.   (setq pt1 (getpoint "\níu░≥⌐│ív▓─ 1 ┬I: "))
  396.   (initget 17)
  397.   (setq pt2 (getpoint pt1 "\níu░≥⌐│ív▓─ 2 ┬I: "))
  398.   (grdraw pt1 pt2 2)
  399.   (initget 17)
  400.   (setq pt3 (getpoint pt2 "\níu░≥⌐│ív▓─ 3 ┬I: "))
  401.   (grdraw pt2 pt3 2)
  402.   (initget 17 "Tetrahedron")          ;Choose 3 or 4 point base
  403.   (setq pt4 (getpoint pt3 "\n TÑ|¡▒┼Θ/<íu░≥⌐│ív▓─ 4 ┬I>: "))
  404.   (if (= pt4 "Tetrahedron")
  405.     (grdraw pt3 pt1 2)
  406.     (progn
  407.       (grdraw pt3 pt4 2)
  408.       (grdraw pt4 pt1 2)
  409.     )
  410.   )
  411.   (cond
  412.     ((= pt4 "Tetrahedron")            ;3 point may have top or apex
  413.       (initget 17 "Top")
  414.       (setq pt5 (getpoint "\nT│╗│í/<│╗┬I>: "))
  415.     )
  416.     (t                                ;4 point may have ridge, top, or apex
  417.       (initget 17 "Top Ridge")
  418.       (setq pt5 (getpoint "\n R¡I»ß/T│╗│í/<│╗┬I>: "))
  419.     )
  420.   )
  421.   (cond
  422.     ((= pt5 "Top")                    ;Prompt for top points
  423.       (initget 17)
  424.       (setq tp1 (getpoint pt1 "\níu│╗│íív▓─ 1 ┬I: "))
  425.       (grdraw pt1 tp1 2)
  426.       (initget 17)
  427.       (setq tp2 (getpoint pt2 "\níu│╗│íív▓─ 2 ┬I: "))
  428.       (grdraw tp1 tp2 2)
  429.       (grdraw pt2 tp2 2)
  430.       (initget 17)
  431.       (setq tp3 (getpoint pt3 "\níu│╗│íív▓─ 3 ┬I: "))
  432.       (grdraw tp2 tp3 2)
  433.       (grdraw pt3 tp3 2)
  434.       (if (/= pt4 "Tetrahedron")
  435.         (progn
  436.           (initget 17)
  437.           (setq tp4 (getpoint pt4 "\níu│╗│íív▓─ 4 ┬I: "))
  438.           (grdraw tp3 tp4 2)
  439.           (grdraw pt4 tp4 2)
  440.         )
  441.       )
  442.     )
  443.     ((= pt5 "Ridge")                  ;Prompt for ridge points
  444.       (grdraw pt4 pt1 2 -1)
  445.       (initget 17)
  446.       (setq tp1 (getpoint "\níu│╗»ßív▓─ 1 ┬I: "))
  447.       (grdraw pt4 pt1 2)
  448.       (grdraw pt1 tp1 2)
  449.       (grdraw pt4 tp1 2)
  450.       (grdraw pt3 pt2 2 -1)
  451.       (initget 17)
  452.       (setq tp2 (getpoint tp1 "\níu│╗»ßív▓─ 2 ┬I: "))
  453.       (grdraw pt2 tp2 2)
  454.       (grdraw pt3 tp2 2)
  455.     )
  456.     (t
  457.       (setq tp1 pt5)                  ;Must be apex
  458.       (setq tp2 tp1)
  459.     )
  460.   )
  461.  
  462.   (cond
  463.     ((and (/= pt4 "Tetrahedron")(/= pt5 "Top"))
  464.       (command "_.3DMESH" "4" "4" tp1 tp1 tp2 tp2 tp1 pt4 pt3 tp2
  465.                 tp1 pt1 pt2 tp2 tp1 tp1 tp2 tp2
  466.       )
  467.     )
  468.     ((and (/= pt4 "Tetrahedron")(= pt5 "Top"))
  469.       (command "_.3DMESH" "5" "4" tp1 tp1 tp2 tp2 tp4 tp4 tp3 tp3
  470.                 tp4 pt4 pt3 tp3 tp1 pt1 pt2 tp2 tp1 tp1 tp2 tp2
  471.       )
  472.     )
  473.     ((and (= pt4 "Tetrahedron")(/= pt5 "Top"))
  474.       (command "_.3DMESH" "5" "2" tp1 pt2 pt3 pt2 pt3 pt1 tp1 pt1
  475.                 tp1 pt2
  476.       )
  477.     )
  478.     (t
  479.       (command "_.3DMESH" "4" "4" pt3 pt1 tp1 tp3 pt2 pt2 tp2 tp2
  480.                 pt3 pt3 tp3 tp3 pt3 pt1 tp1 tp3
  481.       )
  482.     )
  483.   )
  484. )
  485.  
  486. ;;;------------------------------------------------------------------------
  487. ;;; Draw a mesh
  488. ;;;
  489. ;;; Given a starting and an ending point, this function finds the next
  490. ;;; set of points in the N direction.
  491.  
  492. (defun next-n (pt1 pt2 / xinc yinc zinc loop pt)
  493.   (setq xinc (/ (- (car pt2) (car pt1)) (1- n)))
  494.   (setq yinc (/ (- (cadr pt2) (cadr pt1)) (1- n)))
  495.   (setq zinc (/ (- (caddr pt2) (caddr pt1)) (1- n)))
  496.   (setq loop (1- n))
  497.   (setq pt pt1)
  498.   (while (> loop 0)
  499.     (setq pt (list (+ (car pt) xinc) (+ (cadr pt) yinc) (+ (caddr pt) zinc)))
  500.     (command pt)
  501.     (setq loop (1- loop))
  502.   )
  503. )
  504.  
  505. ;;; This function finds the next point in the M direction.
  506.  
  507. (defun next-m (pt1 pt2 loop / xinc yinc zinc)
  508.   (if (/= m loop)
  509.     (progn
  510.       (setq xinc (/ (- (car pt2) (car pt1)) (- m loop)))
  511.       (setq yinc (/ (- (cadr pt2) (cadr pt1)) (- m loop)))
  512.       (setq zinc (/ (- (caddr pt2) (caddr pt1)) (- m loop)))
  513.     )
  514.     (progn
  515.       (setq xinc 0)
  516.       (setq yinc 0)
  517.       (setq zinc 0)
  518.     )
  519.   )
  520.   (setq pt1 (list (+ (car pt1) xinc) (+ (cadr pt1) yinc) (+ (caddr pt1) zinc)))
  521. )
  522.  
  523. (defun mesh (/ c1 c2 c3 c4 m n loop)
  524.   (setq m 0 n 0)                      ;Initialize variables
  525.   (initget 17)
  526.   (setq c1 (getpoint "\n▓─ 1 ¿ñ┬I: "))
  527.   (initget 17)
  528.   (setq c2 (getpoint c1 "\n▓─ 2 ¿ñ┬I: "))
  529.   (grdraw c1 c2 2)
  530.   (initget 17)
  531.   (setq c3 (getpoint c2 "\n▓─ 3 ¿ñ┬I: "))
  532.   (grdraw c2 c3 2)
  533.   (initget 17)
  534.   (setq c4 (getpoint c3 "\n▓─ 4 ¿ñ┬I: "))
  535.   (grdraw c3 c4 2)
  536.   (grdraw c4 c1 2 1)
  537.   (while (or (< m 2) (> m 256))
  538.     (initget 7)
  539.     (setq m (getint "\nM ªV║⌠¡▒╝╞: "))
  540.     (if (or (< m 2) (> m 256))
  541.       (princ "\n╝╞¡╚Ñ▓╢╖ñ╢⌐≤ 2 í╨ 256 íC")
  542.     )
  543.   )
  544.   (grdraw c4 c1 2)
  545.   (grdraw c1 c2 2 1)
  546.   (while (or (< n 2) (> n 256))
  547.     (initget 7)
  548.     (setq n (getint "\nN ªV║⌠¡▒╝╞: "))
  549.     (if (or (< n 2) (> n 256))
  550.       (princ "\n╝╞¡╚Ñ▓╢╖ñ╢⌐≤ 2 í╨ 256 íC")
  551.     )
  552.   )
  553.   (setvar "osmode" 0)                 ;Turn OSMODE off
  554.   (setvar "blipmode" 0)               ;Turn BLIPMODE off
  555.   (command "_.3DMESH" m n)
  556.   (command c1)
  557.   (setq loop 1)
  558.   (next-n c1 c2)
  559.   (while (< loop m)
  560.     (setq c1 (next-m c1 c4 loop))
  561.     (setq c2 (next-m c2 c3 loop))
  562.     (command c1)
  563.     (next-n c1 c2)
  564.     (setq loop (1+ loop))
  565.   )
  566. )
  567.  
  568. ;;;--------------------------------------------------------------------------
  569. ;;; Internal error handler
  570.  
  571. (defun 3derr (s)                      ;If an error (such as CTRL-C) occurs
  572.                                       ;while this command is active...
  573.   (if (/= s "íu¿τ╝╞ív¿·«°")
  574.     (princ (strcat "\n┐∙╗~: " s))
  575.   )
  576.   (if undoit
  577.     (progn
  578.       (command)
  579.       (command "_.UNDO" "_e")            ;Terminate undo group
  580.       (princ "\n½ⁿÑO░hª^...")
  581.       (command "_.U")                   ;Erase partially drawn shape
  582.     )
  583.     (command "_.UNDO" "_e")
  584.   )
  585.   (moder)                             ;Restore saved modes
  586.   (if ofl
  587.     (setvar "FLATLAND" ofl)
  588.   )
  589.   (command "_.REDRAWALL")
  590.   (ai_undo_off)
  591.   (setvar "CMDECHO" oce)              ;Restore saved cmdecho value
  592.   (setq *error* olderr)               ;Restore old *error* handler
  593.   (princ)
  594. )
  595.  
  596. ;;;--------------------------------------------------------------------------
  597. ;;;
  598. ;;; Main program.  Draws 3D object specified by "key" argument.
  599. ;;; If "key" is nil, asks which object is desired.
  600.  
  601. (defun 3d (key / olderr undo_setting)
  602.   (if m:err                           ;If called from the menu
  603.     (setq olderr m:err *error* 3derr) ;save the menus trapped *error*
  604.     (setq olderr *error* *error* 3derr)
  605.   )
  606.   (setq undoit nil ofl nil)
  607.   (setq oce (getvar "cmdecho"))
  608.   (setvar "CMDECHO" 0)
  609.  
  610.   (ai_undo_on)                       ; Turn UNDO on
  611.  
  612.   (modes '("BLIPMODE" "GRIDMODE" "ORTHOMODE" "OSMODE"
  613.            "SURFTAB1" "SURFTAB2" "UCSFOLLOW"))
  614.   ;Test for FLATLAND and FLATLAND's value.
  615.   (if (/= (setq ofl (getvar "FLATLAND")) 0)
  616.     (setvar "FLATLAND" 0)             ;Set FLATLAND for duration
  617.   )                                   ;of the function.
  618.   (command "_.UNDO" "_group")
  619.   (setvar "UCSFOLLOW" 0)
  620.   (setvar "GRIDMODE" 0)
  621.   (setvar "OSMODE" 0)
  622.   (if (null key)
  623.     (progn
  624.       (initget "Box Cone DIsh DOme Mesh Pyramid Sphere Torus Wedge")
  625.       (setq key (getkword
  626.         "\nBÑ▀ñΦ¡▒/C╢Ω└@¡▒/DIñU▓y¡▒/DOñW▓y¡▒/M║⌠¡▒/P¿ñ└@¡▒/S╢Ω▓y¡▒/T└⌠¼W¡▒/W╖ñº╬¡▒: "))
  627.     )
  628.   )
  629.   (cond
  630.     ((= key "Box")     (boxwed  "Ñ▀ñΦ¡▒║c")   )
  631.     ((= key "Cone")    (cone)            )
  632.     ((= key "DIsh")    (spheres "ñU▓y¡▒║c")  )
  633.     ((= key "DOme")    (spheres "ñW▓y¡▒║c")  )
  634.     ((= key "Mesh")    (mesh)            )
  635.     ((= key "Pyramid") (pyramid)         )
  636.     ((= key "Sphere")  (spheres "╢Ω▓y¡▒║c"))
  637.     ((= key "Torus")   (torus)           )
  638.     ((= key "Wedge")   (boxwed  "╖ñº╬¡▒║c") )
  639.     (T nil)                           ;Null reply?  Just exit
  640.   )
  641.   (moder)                             ;Restore saved modes
  642.   (if ofl
  643.     (setvar "FLATLAND" ofl)
  644.   )
  645.   (command "_.REDRAWALL")
  646.   (command "_.UNDO" "_E")             ;Terminate undo group
  647.  
  648.   (ai_undo_off)                       ; Return UNDO to initial state.
  649.  
  650.   (setvar "CMDECHO" oce)              ;Restore saved cmdecho value
  651.   (setq *error* olderr)               ;Restore old *error* handler
  652.   (princ)
  653. )
  654.  
  655. ;;;--------------------------------------------------------------------------
  656. ;;; C: function definitions
  657.  
  658. (defun C:AI_BOX ()     (3d "Box"))
  659. (defun C:AI_CONE ()    (3d "Cone"))
  660. (defun C:AI_DISH ()    (3d "DIsh"))
  661. (defun C:AI_DOME ()    (3d "DOme"))
  662. (defun C:AI_MESH ()    (3d "Mesh"))
  663. (defun C:AI_PYRAMID () (3d "Pyramid"))
  664. (defun C:AI_SPHERE ()  (3d "Sphere"))
  665. (defun C:AI_TORUS ()   (3d "Torus"))
  666. (defun C:AI_WEDGE ()   (3d "Wedge"))
  667. (defun C:3D ()         (3d nil))
  668.  
  669. (princ " íu3D¡▒║c¬½┼Θívñw╕ⁿñJíC")
  670. (princ)
  671.