home *** CD-ROM | disk | FTP | other *** search
/ Windows 95 v2.4 Fix / W95-v2.4fix.iso / ACADWIN / SUPPORT / 3D.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1995-02-08  |  22.0 KB  |  698 lines
  1. ; Next available MSG number is    76 
  2. ; MODULE_ID LSP_3D_LSP_
  3. ;;;
  4. ;;;    3d.lsp
  5. ;;;    
  6. ;;;    Copyright (C) 1988, 1990, 1992, 1994 by Autodesk, Inc.
  7. ;;;
  8. ;;;    Permission to use, copy, modify, and distribute this software
  9. ;;;    for any purpose and without fee is hereby granted, provided
  10. ;;;    that the above copyright notice appears in all copies and
  11. ;;;    that both that copyright notice and the limited warranty and
  12. ;;;    restricted rights notice below appear in all supporting
  13. ;;;    documentation.
  14. ;;;
  15. ;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
  16. ;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
  17. ;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
  18. ;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
  19. ;;;    UNINTERRUPTED OR ERROR FREE.
  20. ;;;
  21. ;;;    Use, duplication, or disclosure by the U.S. Government is subject to
  22. ;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
  23. ;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii) 
  24. ;;;    (Rights in Technical Data and Computer Software), as applicable.
  25. ;;;
  26. ;;;.
  27. ;;;
  28. ;;; Nine 3d objects can be drawn: box, cone, dish, dome, mesh, pyramid,
  29. ;;; sphere, torus, and wedge.
  30. ;;;
  31. ;;; When constructing a pyramid with the "ridge" option, enter the ridge
  32. ;;; points in the same direction as the base points, ridge point one being
  33. ;;; closest to base point one.  This will prevent the "bowtie" effect.
  34. ;;; Note that this is also true for the pyramid's "top" option.
  35. ;;;
  36. ;;;
  37. ;;; ===================== load-time error checking ============================
  38. ;;;
  39.  
  40.   (defun ai_abort (app msg)
  41.      (defun *error* (s)
  42.         (if old_error (setq *error* old_error))
  43.         (princ)
  44.      )
  45.      (if msg
  46.        (alert (strcat " Error en la aplicaci≤n: "
  47.                       app
  48.                       " \n\n  "
  49.                       msg
  50.                       "  \n"
  51.               )
  52.        )
  53.      )
  54.      (exit)
  55.   )
  56.  
  57. ;;; Check to see if AI_UTILS is loaded, If not, try to find it,
  58. ;;; and then try to load it.
  59. ;;;
  60. ;;; If it can't be found or it can't be loaded, then abort the
  61. ;;; loading of this file immediately, preserving the (autoload)
  62. ;;; stub function.
  63.  
  64.   (cond
  65.      (  (and ai_dcl (listp ai_dcl)))          ; it's already loaded.
  66.  
  67.      (  (not (findfile ;|MSG0|;"ai_utils.lsp"))                     ; find it
  68.         (ai_abort "3D"
  69.                   (strcat "Imposible localizar archivo AI_UTILS.LSP."
  70.                           "\n Compruebe el directorio de soporte.")))
  71.  
  72.      (  (eq ;|MSG0|;"failed" (load "ai_utils" ;|MSG0|;"failed")) ;load it
  73.         (ai_abort "3D" "Imposible cargar archivo AI_UTILS.LSP"))
  74.   )
  75.  
  76.   (if (not (ai_acadapp))               ; defined in AI_UTILS.LSP
  77.       (ai_abort "3D" nil)         ; a Nil <msg> supresses
  78.   )                                    ; ai_abort's alert box dialog.
  79.  
  80. ;;; ==================== end load-time operations ===========================
  81.  
  82.  
  83.  
  84. ;;;--------------------------------------------------------------------------
  85. ;;; Allow easier reloads
  86.  
  87. (setq boxwed     nil  
  88.       cone       nil
  89.       mesh       nil
  90.       pyramid    nil
  91.       spheres    nil
  92.       torus      nil
  93.       3derr      nil
  94.       C:3D       nil
  95. )
  96.  
  97. ;;;--------------------------------------------------------------------------
  98. ;;; System variable save
  99.  
  100. (defun modes (a)
  101.   (setq MLST nil)
  102.   (repeat (length a)
  103.     (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  104.     (setq a (cdr a))
  105.   )
  106. )
  107.  
  108. ;;;--------------------------------------------------------------------------
  109. ;;; System variable restore
  110.  
  111. (defun moder ()
  112.   (repeat (length MLST)
  113.     (setvar (caar MLST) (cadar MLST))
  114.     (setq MLST (cdr MLST))
  115.   )
  116. )
  117.  
  118. ;;;--------------------------------------------------------------------------
  119. ;;; Draw a cone
  120.  
  121. (defun cone (/ elev cen1 rad top h numseg cen2 oldelev e1 e2)
  122.   (setq numseg 0)
  123.   (initget 17)                        ;3D point can't be null
  124.   (setq elev (caddr (setq cen1 (getpoint "\nCentro de la base: "))))
  125.   (initget 7 "Dißmetro")              ;Base radius can't be 0, neg, or null
  126.   (setq rad (getdist cen1 "\nDißmetro/<radio> de la base: "))
  127.   (if (= rad "Dißmetro")
  128.     (progn
  129.       (initget 7)                     ;Base diameter can't be 0, neg, or null
  130.       (setq rad (/ (getdist cen1 "\nDißmetro de la base: ") 2.0))
  131.     )
  132.   )
  133.  
  134.   (initget 4 "Dißmetro")              ;Top radius can't be neg
  135.   (setq top (getdist cen1 "\nDißmetro/<radio> superior <0>: "))
  136.   (if (= top "Dißmetro")
  137.     (progn
  138.       (initget 4)                     ;Top diameter can't be neg
  139.       (setq top (getdist cen1 "\nDißmetro superior <0>: "))
  140.       (if top
  141.         (setq top (/ top 2.0))
  142.       )
  143.     )
  144.   )
  145.   (if (null top)
  146.     (setq top 0.0)
  147.   )
  148.   
  149.   (initget 7 "Altura")                ;Height can't be 0, neg, or null
  150.   (setq h (getdist cen1 "\nAltura: "))
  151.  
  152.   (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
  153.     (initget 6)
  154.     (setq numseg (getint "\nN·mero de segmentos <16>: "))
  155.     (if (null numseg)
  156.       (setq numseg 16)
  157.     )  
  158.     (if (< numseg 2)
  159.       (princ "\nTiene que haber mßs de 1 segmento.")
  160.     )
  161.   )
  162.   (setvar "SURFTAB1" numseg)
  163.  
  164.   (command "_.CIRCLE" cen1 rad)         ;Draw base circle
  165.   (setq undoit T)
  166.   (setq e1 (entlast))
  167.   (setq cen2 (list (car cen1) (cadr cen1) (+ (caddr cen1) h)))
  168.   (setq oldelev (getvar "ELEVATION"))
  169.   (command "_.ELEV" (+ elev h) "")
  170.   (cond 
  171.     ;;Draw top point or circle
  172.     ((= top 0.0) (command "_.POINT" cen2))  
  173.     (t (command "_.CIRCLE" cen2 top))
  174.   )
  175.   (setq e2 (entlast))
  176.   (setvar "ELEVATION" oldelev)
  177.  
  178.   (command "_.RULESURF" (list e1 cen1) (list e2 cen2)) ;Draw cone
  179.   (entdel e1) 
  180.   (entdel e2)
  181. )
  182.  
  183. ;;;--------------------------------------------------------------------------
  184. ;;; Draw a sphere, dome, or dish
  185.  
  186. (defun spheres (typ / cen r numseg ax ax1 e1 e2)
  187.   (setq numseg 0)
  188.   (initget 17)                        ;3D point can't be null
  189.   (setq cen (getpoint (strcat "\nCentro de " typ": ")))
  190.   (initget 7 "Dißmetro")              ;Radius can't be 0, neg, or null
  191.   (setq r (getdist cen (strcat "\nDißmetro/<radio>: ")))
  192.   (if (= r "Dißmetro")
  193.     (progn
  194.       (initget 7)                     ;Diameter can't be 0, neg, or null
  195.       (setq r (/ (getdist cen (strcat "\nDißmetro: ")) 2.0))
  196.     )
  197.   )
  198.   (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
  199.         
  200.   (while (< numseg 2)                 ;SURFTAB1 can't be less than 2
  201.     (initget 6)
  202.     (setq numseg (getint "\nN·mero de segmentos longitudinales <16>: "))
  203.     (if (null numseg)
  204.       (setq numseg 16)
  205.     )
  206.     (if (< numseg 2)
  207.       (princ "\nTiene que haber mßs de 1 segmento.")
  208.     )
  209.   )
  210.   (setvar "SURFTAB1" numseg)
  211.    
  212.   (setq numseg 0)
  213.   (while (< numseg 2)                 ;SURFTAB2 can't be less than 2
  214.     (initget 6)
  215.     (princ "\nN·mero de segmentos latitudinales ") 
  216.     (if (= typ "esfera")
  217.       (princ "<16>: ")                ;Set default to 16 for a sphere
  218.       (princ "<8>: ")                 ;Set default to 8 for a dome or dish
  219.     )
  220.     (setq numseg (getint))
  221.     (if (null numseg)
  222.       (if (= typ "esfera")
  223.         (setq numseg 16)
  224.         (setq numseg 8)
  225.       )
  226.     )
  227.     (if (< numseg 2)
  228.       (princ "\nTiene que haber mßs de 1 segmento.")
  229.     )
  230.   )
  231.   (setvar "SURFTAB2" numseg)
  232.  
  233.   (command "_.UCS" "_x" "90")
  234.   (setq undoit T)
  235.  
  236.   (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  237.   (cond
  238.     ((= typ "esfera")
  239.       (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
  240.       (setq ax1 (list (car cen) (- (cadr cen) r) (caddr cen)))
  241.       (command "_.LINE" ax ax1 "")      ;Draw axis of revolution
  242.       (setq e1 (entlast))
  243.       ;;Draw path curve
  244.       (command "_.ARC" ax ;|MSG0|;"_e" ax1 ;|MSG0|;"_a" "180.0") 
  245.       (setq e2 (entlast))
  246.     )
  247.     (t
  248.       (if (= typ "c·pula")
  249.         (setq ax (list (car cen) (+ (cadr cen) r) (caddr cen)))
  250.         (setq ax (list (car cen) (- (cadr cen) r) (caddr cen)))
  251.       )
  252.       (command "_.LINE" cen ax "")      ;Draw axis of revolution
  253.       (setq e1 (entlast))
  254.       ;;Draw path curve
  255.       (command "_.ARC" "_c" cen ax ;|MSG0|;"_a" "90.0") 
  256.       (setq e2 (entlast))
  257.     )
  258.   )
  259.  
  260.   ;;Draw dome or dish
  261.   (command "_.REVSURF" (list e2 ax) (list e1 cen) "" "") 
  262.   (entdel e1)                 
  263.   (entdel e2)
  264.   (command "_.UCS" "_prev")
  265. )
  266.  
  267. ;;;--------------------------------------------------------------------------
  268. ;;; Draw a torus
  269.  
  270. (defun torus (/ cen l trad numseg hrad tcen ax e1 e2)
  271.   (setq numseg 0)
  272.   (initget 17)                        ;3D point can't be null
  273.   (setq cen (getpoint "\nCentro del toroide: "))
  274.   (setq trad 0 l -1)
  275.   (while (> trad (/ l 2.0))
  276.     (initget 7 "Dißmetro")            ;Radius can't be 0, neg, or null
  277.     (setq l (getdist cen "\nDißmetro/<radio> del toroide: "))
  278.     (if (= l "Dißmetro")
  279.       (progn
  280.         (initget 7)                   ;Diameter can't be 0, neg, or null
  281.         (setq l (/ (getdist cen "\nDißmetro: ") 2.0))
  282.       )
  283.     )
  284.     (initget 7 "Dißmetro")            ;Radius can't be 0, neg, or null
  285.     (setq trad (getdist cen "\nDißmetro/<radio> de la secci≤n: "))
  286.     (if (= trad "Dißmetro")
  287.       (progn
  288.         (initget 7)
  289.         (setq trad (/ (getdist cen "\nDißmetro: ") 2.0))
  290.       )
  291.     )
  292.     (if (> trad (/ l 2.0))
  293.       (prompt "\nEl dißmetro de la secci≤n no puede exceder el radio del toroide.")
  294.     )
  295.   )
  296.   (setq cen (trans cen 1 0))          ;Translate from UCS to WCS
  297.  
  298.   (while (< numseg 2)
  299.     (initget 6)                       ;SURFTAB1 can't be 0 or neg
  300.     (setq numseg (getint "\nSegmentos alrededor de la circunferencia de la secci≤n <16>: "))
  301.     (if (null numseg)
  302.       (setq numseg 16)
  303.     )
  304.     (if (< numseg 2)
  305.       (princ "\nTiene que haber mßs de 1 segmento.")
  306.     )
  307.   )
  308.   (setvar "SURFTAB1" numseg)
  309.  
  310.   (setq numseg 0)
  311.   (while (< numseg 2)
  312.     (initget 6)                       ;SURFTAB2 can't be 0 or neg
  313.     (setq numseg (getint "\nSegmentos alrededor de la circunferencia del toroide <16>: "))
  314.     (if (null numseg)
  315.       (setq numseg 16)
  316.     )
  317.     (if (< numseg 2)
  318.       (princ "\nTiene que haber mßs de 1 segmento.")
  319.     )
  320.   )
  321.   (setvar "SURFTAB2" numseg)
  322.  
  323.   (command "_.UCS" "_x" "90")
  324.   (setq undoit T)
  325.  
  326.   (setq cen (trans cen 0 1))          ;Translate from WCS to UCS
  327.   (setq hrad (- l (* trad 2.0)))
  328.   (setq tcen (list (+ (+ (car cen) trad) hrad) (cadr cen) (caddr cen)))
  329.   (setq ax (list (car cen) (+ (cadr cen) 2.0) (caddr cen)))
  330.  
  331.   (command "_.CIRCLE" tcen trad)        ;Draw path curve
  332.   (setq e1 (entlast))
  333.   (command "_.LINE" cen ax "")          ;Draw axis of revolution
  334.   (setq e2 (entlast))
  335.   (command "_.REVSURF" (list e1 tcen) (list e2 ax) "" "") ;Draw torus
  336.   (entdel e1)            
  337.   (entdel e2)
  338.   (command "_.UCS" "_prev")
  339. )
  340.  
  341. ;;;--------------------------------------------------------------------------
  342. ;;; Draw a box or wedge
  343.  
  344. (defun boxwed (typ / pt1 l w h1 h2 a ang pt2 pt3 pt4 pt5 pt6 pt7 pt8 lockflag)
  345.   (initget 17)                        ;3D point can't be null
  346.   (setq pt1 (getpoint (strcat "\nEsquina de "typ": ")))
  347.   (setvar "ORTHOMODE" 1)
  348.   (initget 7)                         ;Length can't be 0, neg, or null
  349.   (setq l (getdist pt1 "\nLongitud: "))
  350.   (setq pt3 (list (+ (car pt1) l) (cadr pt1) (caddr pt1)))
  351.   (grdraw pt1 pt3 2)
  352.   (cond 
  353.     ((= typ "calce")
  354.       (initget 7)                     ;Width can't be 0, neg, or null
  355.       (setq w (getdist pt1 "\nAnchura: "))
  356.     )
  357.     (t 
  358.       (initget 7 "Cubo")              ;Width can't be 0, neg, or null
  359.       (setq w (getdist pt1 "\nCubo/<anchura>: "))
  360.       (if (= w "Cubo") 
  361.          (setq w l h1 l h2 l)
  362.       )
  363.     )
  364.   )
  365.   (setq pt2 (list (car pt1) (+ (cadr pt1) w) (caddr pt1)))
  366.   (setq pt4 (list (car pt3) (+ (cadr pt3) w) (caddr pt3)))
  367.   (grdraw pt3 pt4 2)
  368.   (grdraw pt4 pt2 2)
  369.   (grdraw pt2 pt1 2)
  370.   (setvar "ORTHOMODE" 0)
  371.   (cond 
  372.     ((= typ "calce")
  373.       (initget 7)                     ;Height can't be 0, neg, or null
  374.       (setq h1 (getdist pt1 "\nAltura: "))
  375.       (setq h2 0.0)
  376.     )
  377.     (t  
  378.       (if (/= h1 l) 
  379.         (progn
  380.           (initget 7)                 ;Height can't be 0, neg, or null
  381.           (setq h1 (getdist pt1 "\nAltura: "))
  382.           (setq h2 h1)
  383.         )
  384.       )
  385.     )
  386.   )
  387.  
  388.   (setq pt5 (list (car pt3) (cadr pt3) (+ (caddr pt3) h2)))
  389.   (setq pt6 (list (car pt4) (cadr pt4) (+ (caddr pt4) h2)))
  390.   (setq pt7 (list (car pt1) (cadr pt1) (+ (caddr pt1) h1)))
  391.   (setq pt8 (list (car pt2) (cadr pt2) (+ (caddr pt2) h1)))
  392.   (command "_.3DMESH" "6" "3" pt5 pt3 pt3 pt7 pt1 pt1 pt8 pt2
  393.             pt1 pt6 pt4 pt3 pt6 pt6 pt5 pt8 pt8 pt7
  394.   )            
  395.  
  396.   (setq undoit T)
  397.   (prompt "\nAngulo de rotaci≤n sobre el eje Z: ")
  398.  
  399.   ;; Cannot ROTATE on locked layer. Temporarily unlock layer, if need be.
  400.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar "clayer"))))))
  401.     (progn 
  402.       (command "_.LAYER" "_UNLOCK" (getvar "clayer") "")
  403.       (setq lockflag 1)
  404.     )
  405.   )
  406.  
  407.   (prompt "\nAngulo de rotaci≤n sobre el eje Z: ")
  408.   (command "_.ROTATE" (entlast) "" pt1 pause)
  409.  
  410.   ;; ReLock if need be.
  411.   (if (= 1 lockflag)
  412.     (command "._LAYER" "_LOCK" (getvar "clayer") "")
  413.   )
  414. )
  415.  
  416. ;;;--------------------------------------------------------------------------
  417. ;;; Draw a pyramid
  418.  
  419. (defun pyramid (/ pt1 pt2 pt3 pt4 pt5 tp1 tp2 tp3 tp4)
  420.   (initget 17)                        ;3D point can't be null
  421.   (setq pt1 (getpoint "\nPrimer punto de base: "))
  422.   (initget 17)
  423.   (setq pt2 (getpoint pt1 "\nSegundo punto de base: "))
  424.   (grdraw pt1 pt2 2)
  425.   (initget 17)
  426.   (setq pt3 (getpoint pt2 "\nTercer punto de base: ")) 
  427.   (grdraw pt2 pt3 2)
  428.   (initget 17 "Tetraedro")          ;Choose 3 or 4 point base
  429.   (setq pt4 (getpoint pt3 "\nTetraedro/<cuarto punto de base>: ")) 
  430.   (if (= pt4 "Tetraedro")
  431.     (grdraw pt3 pt1 2)
  432.     (progn
  433.       (grdraw pt3 pt4 2)
  434.       (grdraw pt4 pt1 2)
  435.     )
  436.   )
  437.   (cond 
  438.     ((= pt4 "Tetraedro")            ;3 point may have top or apex
  439.       (initget 17 "Superior")
  440.       (setq pt5 (getpoint "\nSuperior/<punto de vΘrtice>: "))
  441.     )
  442.     (t                                ;4 point may have ridge, top, or apex
  443.       (initget 17 "Superior Arista") 
  444.       (setq pt5 (getpoint "\nArista/Superior/<punto de vΘrtice>: "))
  445.     )
  446.   )
  447.   (cond 
  448.     ((= pt5 "Superior")                    ;Prompt for top points
  449.       (initget 17)
  450.       (setq tp1 (getpoint pt1 "\nPrimer punto superior: "))
  451.       (grdraw pt1 tp1 2)
  452.       (initget 17)
  453.       (setq tp2 (getpoint pt2 "\nSegundo punto superior: "))
  454.       (grdraw tp1 tp2 2)
  455.       (grdraw pt2 tp2 2)
  456.       (initget 17)
  457.       (setq tp3 (getpoint pt3 "\nTercer punto superior: "))
  458.       (grdraw tp2 tp3 2)
  459.       (grdraw pt3 tp3 2)
  460.       (if (/= pt4 "Tetraedro")
  461.         (progn
  462.           (initget 17)
  463.           (setq tp4 (getpoint pt4 "\nCuarto punto superior: "))
  464.           (grdraw tp3 tp4 2)
  465.           (grdraw pt4 tp4 2)
  466.         )
  467.       )
  468.     )
  469.     ((= pt5 "Arista")                  ;Prompt for ridge points
  470.       (grdraw pt4 pt1 2 -1)
  471.       (initget 17)                
  472.       (setq tp1 (getpoint "\nPrimer punto de arista: "))
  473.       (grdraw pt4 pt1 2)
  474.       (grdraw pt1 tp1 2)
  475.       (grdraw pt4 tp1 2)
  476.       (grdraw pt3 pt2 2 -1)
  477.       (initget 17)                
  478.       (setq tp2 (getpoint tp1 "\nSegundo punto de arista: "))
  479.       (grdraw pt2 tp2 2)
  480.       (grdraw pt3 tp2 2)
  481.     )
  482.     (t 
  483.       (setq tp1 pt5)                  ;Must be apex
  484.       (setq tp2 tp1)
  485.     )
  486.   )
  487.  
  488.   (cond 
  489.     ((and (/= pt4 "Tetraedro")(/= pt5 "Superior"))
  490.       (command "_.3DMESH" "4" "4" tp1 tp1 tp2 tp2 tp1 pt4 pt3 tp2 
  491.                 tp1 pt1 pt2 tp2 tp1 tp1 tp2 tp2
  492.       )
  493.     )
  494.     ((and (/= pt4 "Tetraedro")(= pt5 "Superior"))
  495.       (command "_.3DMESH" "5" "4" tp1 tp1 tp2 tp2 tp4 tp4 tp3 tp3
  496.                 tp4 pt4 pt3 tp3 tp1 pt1 pt2 tp2 tp1 tp1 tp2 tp2
  497.       )
  498.     )
  499.     ((and (= pt4 "Tetraedro")(/= pt5 "Superior"))
  500.       (command "_.3DMESH" "5" "2" tp1 pt2 pt3 pt2 pt3 pt1 tp1 pt1 
  501.                 tp1 pt2
  502.       )
  503.     )
  504.     (t 
  505.       (command "_.3DMESH" "4" "4" pt3 pt1 tp1 tp3 pt2 pt2 tp2 tp2
  506.                 pt3 pt3 tp3 tp3 pt3 pt1 tp1 tp3
  507.       )
  508.     )
  509.   )     
  510. )
  511.  
  512. ;;;------------------------------------------------------------------------
  513. ;;; Draw a mesh
  514. ;;;
  515. ;;; Given a starting and an ending point, this function finds the next
  516. ;;; set of points in the N direction.
  517.  
  518. (defun next-n (pt1 pt2 / xinc yinc zinc loop pt)
  519.   (setq xinc (/ (- (car pt2) (car pt1)) (1- n)))
  520.   (setq yinc (/ (- (cadr pt2) (cadr pt1)) (1- n)))
  521.   (setq zinc (/ (- (caddr pt2) (caddr pt1)) (1- n)))
  522.   (setq loop (1- n))
  523.   (setq pt pt1)
  524.   (while (> loop 0)
  525.     (setq pt (list (+ (car pt) xinc) (+ (cadr pt) yinc) (+ (caddr pt) zinc)))
  526.     (command pt)
  527.     (setq loop (1- loop))
  528.   )
  529. )
  530.  
  531. ;;; This function finds the next point in the M direction.
  532.  
  533. (defun next-m (pt1 pt2 loop / xinc yinc zinc)
  534.   (if (/= m loop)
  535.     (progn
  536.       (setq xinc (/ (- (car pt2) (car pt1)) (- m loop)))
  537.       (setq yinc (/ (- (cadr pt2) (cadr pt1)) (- m loop)))
  538.       (setq zinc (/ (- (caddr pt2) (caddr pt1)) (- m loop)))
  539.     )
  540.     (progn
  541.       (setq xinc 0)
  542.       (setq yinc 0)
  543.       (setq zinc 0)
  544.     )
  545.   )
  546.   (setq pt1 (list (+ (car pt1) xinc) (+ (cadr pt1) yinc) (+ (caddr pt1) zinc)))
  547. )
  548.  
  549. (defun mesh (/ c1 c2 c3 c4 m n loop)
  550.   (setq m 0 n 0)                      ;Initialize variables
  551.   (initget 17)                     
  552.   (setq c1 (getpoint "\nPrimera esquina: "))
  553.   (initget 17)                     
  554.   (setq c2 (getpoint c1 "\nSegunda esquina: "))
  555.   (grdraw c1 c2 2)
  556.   (initget 17)                     
  557.   (setq c3 (getpoint c2 "\nTercera esquina: "))
  558.   (grdraw c2 c3 2)
  559.   (initget 17)                     
  560.   (setq c4 (getpoint c3 "\nCuarta esquina "))
  561.   (grdraw c3 c4 2)
  562.   (grdraw c4 c1 2 1)
  563.   (while (or (< m 2) (> m 256))
  564.     (initget 7)                     
  565.     (setq m (getint "\nTama±o M de la malla: "))
  566.     (if (or (< m 2) (> m 256)) 
  567.       (princ "\nEl valor debe estar entre 2 y 256.")
  568.     )
  569.   )
  570.   (grdraw c4 c1 2)
  571.   (grdraw c1 c2 2 1)
  572.   (while (or (< n 2) (> n 256))
  573.     (initget 7)                     
  574.     (setq n (getint "\nTama±o N de la malla: "))
  575.     (if (or (< n 2) (> n 256)) 
  576.       (princ "\nEl valor debe estar entre 2 y 256.")
  577.     )
  578.   )
  579.   (setvar "osmode" 0)                 ;Turn OSMODE off
  580.   (setvar "blipmode" 0)               ;Turn BLIPMODE off
  581.   (command "_.3DMESH" m n)
  582.   (command c1)
  583.   (setq loop 1)
  584.   (next-n c1 c2)
  585.   (while (< loop m)
  586.     (setq c1 (next-m c1 c4 loop)) 
  587.     (setq c2 (next-m c2 c3 loop))
  588.     (command c1)
  589.     (next-n c1 c2)
  590.     (setq loop (1+ loop))
  591.   )
  592. )
  593.  
  594. ;;;--------------------------------------------------------------------------
  595. ;;; Internal error handler
  596.  
  597. (defun 3derr (s)                      ;If an error (such as CTRL-C) occurs
  598.                                       ;while this command is active...
  599.   (if (/= s "Funci≤n cancelada")
  600.     (princ (strcat "\nError: " s))
  601.   )
  602.   (if undoit
  603.     (progn
  604.       (command)
  605.       (command "_.UNDO" "_e")            ;Terminate undo group
  606.       (princ "\ndeshaciendo...") 
  607.       (command "_.U")                   ;Erase partially drawn shape
  608.     )
  609.     (command "_.UNDO" "_e")               
  610.   )
  611.   (moder)                             ;Restore saved modes
  612.   (if ofl
  613.     (setvar "FLATLAND" ofl)
  614.   )
  615.   (command "_.REDRAWALL")
  616.   (ai_undo_off)
  617.   (setvar "CMDECHO" oce)              ;Restore saved cmdecho value
  618.   (setq *error* olderr)               ;Restore old *error* handler
  619.   (princ)
  620. )
  621.  
  622. ;;;--------------------------------------------------------------------------
  623. ;;;
  624. ;;; Main program.  Draws 3D object specified by "key" argument.
  625. ;;; If "key" is nil, asks which object is desired.
  626.  
  627. (defun 3d (key / olderr undo_setting)
  628.   (if m:err                           ;If called from the menu
  629.     (setq olderr m:err *error* 3derr) ;save the menus trapped *error*
  630.     (setq olderr *error* *error* 3derr)
  631.   )
  632.   (setq undoit nil ofl nil)
  633.   (setq oce (getvar "cmdecho"))
  634.   (setvar "CMDECHO" 0)
  635.  
  636.   (ai_undo_on)                       ; Turn UNDO on
  637.  
  638.   (modes '(;|MSG0|;"BLIPMODE" "GRIDMODE" "ORTHOMODE" "OSMODE"
  639.            "SURFTAB1" "SURFTAB2" "UCSFOLLOW"))
  640.   ;Test for FLATLAND and FLATLAND's value.
  641.   (if (/= (setq ofl (getvar "FLATLAND")) 0) 
  642.     (setvar "FLATLAND" 0)             ;Set FLATLAND for duration
  643.   )                                   ;of the function.
  644.   (command "_.UNDO" "_group")
  645.   (setvar "UCSFOLLOW" 0)
  646.   (setvar "GRIDMODE" 0)
  647.   (setvar "OSMODE" 0)
  648.   (if (null key)
  649.     (progn
  650.       (initget "pRisma cOno cUenco C·pula Malla Pirßmide Esfera Toroide cAlce")
  651.       (setq key (getkword 
  652.         "\npRisma rectangular/cOno/cUenco/C·pula/Malla/Pirßmide/Esfera/Toroide/cAlce: "))
  653.     )
  654.   )
  655.   (cond 
  656.     ((= key "pRisma")     (boxwed  "prisma rectangular")   ) 
  657.     ((= key "cOno")    (cone)            )
  658.     ((= key "cUenco")    (spheres "cuenco")  )
  659.     ((= key "C·pula")    (spheres "c·pula")  )
  660.     ((= key "Malla")    (mesh)            )
  661.     ((= key "Pirßmide") (pyramid)         )
  662.     ((= key "Esfera")  (spheres "esfera"))
  663.     ((= key "Toroide")   (torus)           )
  664.     ((= key "cAlce")   (boxwed  "calce") )
  665.     (T nil)                           ;Null reply?  Just exit
  666.   )
  667.   (moder)                             ;Restore saved modes
  668.   (if ofl
  669.     (setvar "FLATLAND" ofl)
  670.   )
  671.   (command "_.REDRAWALL")
  672.   (command "_.UNDO" "_E")             ;Terminate undo group
  673.  
  674.   (ai_undo_off)                       ; Return UNDO to initial state.
  675.  
  676.   (setvar "CMDECHO" oce)              ;Restore saved cmdecho value
  677.   (setq *error* olderr)               ;Restore old *error* handler
  678.   (princ)
  679. )
  680.  
  681. ;;;--------------------------------------------------------------------------
  682. ;;; C: function definitions
  683.  
  684. (defun C:AI_BOX ()     (3d "pRisma"))
  685. (defun C:AI_CONE ()    (3d "cOno"))
  686. (defun C:AI_DISH ()    (3d "cUenco"))
  687. (defun C:AI_DOME ()    (3d "C·pula"))
  688. (defun C:AI_MESH ()    (3d "Malla"))
  689. (defun C:AI_PYRAMID () (3d "Pirßmide"))
  690. (defun C:AI_SPHERE ()  (3d "Esfera"))
  691. (defun C:AI_TORUS ()   (3d "Toroide"))
  692. (defun C:AI_WEDGE ()   (3d "cAlce"))
  693. (defun C:3D ()         (3d nil))
  694.  
  695. (princ "  Objetos 3D cargados.")
  696. (princ)
  697.  
  698.