home *** CD-ROM | disk | FTP | other *** search
/ Program Metropolis - Software Boutique 95 / SOFTWARECD.iso / cacad12 / disk11 / bonus2.lib / MFACE.LSP < prev    next >
Encoding:
Text File  |  1993-02-09  |  6.3 KB  |  222 lines
  1. ;;;   MFACE.LSP
  2. ;;;   (C) ¬⌐┼v 1988-1992  Autodesk ñ╜Ñq
  3. ;;;
  4. ;;;   Ñ╗╡{ªíñwÑ╤ Autodesk ñ╜Ñq╡∙ÑU¬⌐┼v, ╢╚⌐≤ñU¡z▒í¬pñUÑi▒┬╗P▒zíu│\ÑiívíC
  5. ;;;   ╗╒ñUñú▒oÑHÑ⌠ª≤º╬ªí╡oªµ⌐╬ÑX¬⌐ª╣╡{ªí¬║íu¡∞⌐l╜Xív; ª²ñ╣│\▒zªb»S⌐w¡lÑ═
  6. ;;;   ¬║ñuº@ñW╡▓ªXª╣╡{ªí¬║íuÑ╪¬║╜Xív¿╧Ñ╬íCª│├÷│o├■¡lÑ═ñuº@¬║▒°Ñ≤ªpñU:
  7. ;;;
  8. ;;;   ( i)  │]¡pñW╗Pñuº@ñW¼╥»┬║Θ░w╣∩ Autodesk ñ╜Ñq¬║▓ú½~íC
  9. ;;;   (ii)  ╕ⁿª│íu¬⌐┼v  (C) 1988-1992  Autodesk ñ╜Ñqív¬║¬⌐┼v│qºiíC
  10. ;;;
  11. ;;;
  12. ;;;
  13. ;;;   AUTODESKñ╜Ñq┤ú¿╤ª╣╡{ªí╢╚¿╤º@íu├■ªⁿív¬║░╤ª╥, ª╙ÑBñú▒╞░úª│Ñ⌠ª≤┐∙╗~¬║
  14. ;;;   Ñi»αíCAUTODESKñ╜Ñq»Sª╣º_╗{Ñ⌠ª≤»S⌐wÑ╬│~ñº╛A║┘⌐╩, ÑHñ╬░╙╖~╛P░Γ⌐╥┴⌠ºt
  15. ;;;   ÑX¿π¬║½O├╥íCAUTODESKñ╜ÑqªP«╔ÑτñúÑX¿πª╣╡{ªí░⌡ªµ«╔ñ@⌐wñú╖|íuññ┬_ív⌐╬
  16. ;;;   íuº╣Ñ■╡L╗~ív¬║½O├╥íC
  17. ;;;
  18. ;;;
  19. ;;;--------------------------------------------------------------------------
  20. ;;; DESCRIPTION
  21. ;;;   C:MFACE -- Pmesh creator.
  22. ;;;
  23. ;;;   This routine is a front end to the PFACE
  24. ;;;   command in AutoCAD.  It allows the user to easily
  25. ;;;   create pface meshes at the command prompt.
  26.  
  27. ;;;   Training Department / J.F.
  28. ;;;   5/04/90
  29. ;;;
  30. ;;;----- Redefined error function ----------------------------
  31.  
  32. (defun newerr (s)
  33.   (if (/= s "Function cancelled")
  34.       (princ (strcat "\n┐∙╗~: " s))
  35.   )
  36.   (setq *error* olderr)
  37.   (setvar "CMDECHO" cmdecho)
  38.   (redraw)
  39.   (princ)
  40. )
  41.  
  42. ;;;
  43. ;;;----- Draw PFACE ----------------------------------------
  44. ;;;
  45. (defun drawrat ()
  46.   (command "_.PFACE")
  47.   (while (car vlist)
  48.     (command (car vlist))
  49.     (setq vlist (cdr vlist))
  50.   )
  51.   (command "")
  52.   (while (setq facelist (car masterfl))
  53.     (command "_.COLOR" (car colorlst))
  54.     (command "_.LAYER" (car layerlst))
  55.     (while (car facelist)
  56.            (command (car facelist))
  57.            (setq facelist (cdr facelist))
  58.     )
  59.     (command "")
  60.     (setq layerlst (cdr layerlst))
  61.     (setq colorlst (cdr colorlst))
  62.     (setq masterfl (cdr masterfl))
  63.   )
  64.   (command "")
  65. )
  66.  
  67. ;;;
  68. ;;;----- Find current entity color ---------------------------
  69. ;;; The system variable "CECOLOR" gives the color number and
  70. ;;; the color name (i.e. "1 red") for the first 7 colors.
  71. ;;; This function strips the color name and returns the color
  72. ;;; number.
  73. ;;;
  74. (defun getcolor (/ max ctr cecolor)
  75.   (setq colnam nil)
  76.   (setq cecolor (getvar "CECOLOR"))
  77.   (setq ctr 1)
  78.   (setq max (strlen cecolor))
  79.   (while (< ctr max)
  80.     (if (= (substr cecolor ctr 1) " ")
  81.       (progn
  82.         (setq colnam (substr cecolor 1 (- ctr 1)))
  83.         (setq ctr max)
  84.       )
  85.       (setq ctr (1+ ctr))
  86.     )
  87.   )
  88.   (if (not colnam) (setq colnam cecolor))
  89. )
  90.  
  91. ;;;
  92. ;;;----- Prompt for layer, chk table, add to layer list ------
  93. ;;;
  94. (defun setlay (/ oldlnam)
  95.   (setq oldlnam laynam)
  96.   (setq laynam
  97.       (getstring (strcat "\n╝hªW <" oldlnam ">: "))
  98.   )
  99.   (if (= laynam "")                   ;if accepting default layer name
  100.     (setq laynam oldlnam)             ;then set to default
  101.     (progn                            ;else check layer table
  102.       (while (not (tblsearch "LAYER" laynam))
  103.         (prompt (strcat "\nºΣñú¿∞íu╣╧╝h " laynam "ívíC"))
  104.         (setq laynam
  105.           (getstring (strcat "\n╝hªW <" oldlnam ">: "))
  106.         )
  107.         (if (= laynam "") (setq laynam oldlnam))
  108.       )
  109.     )
  110.   )
  111. )
  112. ;;;
  113. ;;;----- Prompt for color, convert # to string ---------------
  114. ;;;
  115. (defun setcol (/ oldcolor)
  116.   (setq oldcolor colnam)
  117.   (initget "Red Blue Green Cyan Byblock Yellow Magenta White Bylayer")
  118.   (setq colnam
  119.     (getint (strcat "\n├CªΓ╜X <" colnam ">: "))
  120.   )
  121.   (cond
  122.     ((numberp colnam) (setq colnam (itoa colnam)))
  123.     ((equal colnam nil) (setq colnam oldcolor))
  124.   )
  125. )
  126.  
  127. ;;;
  128. ;;; ----- Set grdraw color -----------------------------------
  129. ;;; This function set the color number for the grdraw function
  130. ;;; if GRCOLOR does not contain the color number (i.e. if
  131. ;;; set to "red" it would change it to "1").
  132. ;;;
  133. (defun subcolor ()
  134.   (cond
  135.     ((equal grcolor "Red")     (setq grcolor 1))
  136.     ((equal grcolor "Yellow")  (setq grcolor 2))
  137.     ((equal grcolor "Green")   (setq grcolor 3))
  138.     ((equal grcolor "Cyan")    (setq grcolor 4))
  139.     ((equal grcolor "Blue")    (setq grcolor 5))
  140.     ((equal grcolor "Magenta") (setq grcolor 6))
  141.     ((equal (strcase grcolor) "BYLAYER") ;find layer color
  142.       (setq laylist (tblsearch "layer" (last layerlst)))
  143.       (setq grcolor (cdr (assoc 62 laylist)))
  144.     )
  145.     ((equal (strcase grcolor) "BYBLOCK") (setq grcolor 7))
  146.     ( T (setq grcolor (atoi grcolor)))
  147.   )
  148. )
  149.  
  150. ;;;
  151. ;;;----- Add vertex to face list, find order in list ---------
  152. ;;; This function adds the vertex point to the vertex list if
  153. ;;; it is not in the vertex list.  Then it finds the order of
  154. ;;; the vertex in the list and add it to the face list.
  155. ;;;
  156. (defun addpt (/ remain remain-l vlist-l v-order)
  157.   (if (not (setq remain (member pt vlist)))
  158.     (progn
  159.       (setq vlist (append vlist (list pt)))
  160.       (setq remain (member pt vlist))
  161.     )
  162.   )
  163.   (setq remain-l (length remain))
  164.   (setq vlist-l (length vlist))
  165.   (setq v-order (1+ (- vlist-l remain-l)))
  166.   (setq facelist (append facelist (list v-order)))
  167. )
  168.  
  169. ;;;
  170. ;;;----- Get vertex, add face list to master face list -------
  171. ;;;
  172. (defun getvts (/ grcolor 1st prev-pt)
  173.   (setq layerlst (append layerlst (list laynam)))
  174.   (setq colorlst (append colorlst (list colnam)))
  175.   (setq grcolor colnam ctr 1)
  176.   (if (not (numberp grcolor)) (subcolor))
  177.   (setq prev-pt pt) (setq 1st pt)
  178.   (while (setq pt (getpoint pt "\n┐∩╛▄íu│╗┬Iív: "))
  179.     (grdraw prev-pt pt grcolor 0)
  180.     (if (> ctr 2)
  181.       (grdraw 1st pt grcolor 1)
  182.     )
  183.     (setq prev-pt pt)
  184.     (addpt)
  185.     (setq ctr (1+ ctr))
  186.   )
  187.   (grdraw prev-pt 1st grcolor 0)
  188.   (setq masterfl (append masterfl (list facelist)))
  189.   (setq facelist nil)
  190. )
  191.  
  192. ;;;
  193. ;;;----- Primary function ------------------------------------
  194. ;;;
  195. (defun C:MFACE (/ facelist masterfl vlist colorlst layerlst
  196.                    laynam pt)
  197.   (setq olderr  *error*
  198.         *error* newerr
  199.         again   T
  200.         cmdecho (getvar "CMDECHO")
  201.         laynam  (getvar "CLAYER")
  202.   )
  203.   (setvar "CMDECHO" 0)
  204.   (getcolor)
  205.   (while again
  206.     (initget "Color Layer")
  207.     (setq pt (getpoint "\nL╣╧╝h/C├CªΓ/<┐∩╛▄íu│╗┬Iív>: "))
  208.     (cond
  209.       ((equal pt "Color") (setcol))
  210.       ((equal pt "Layer") (setlay))
  211.       ((not pt) (setq again nil))
  212.       (T (addpt) (getvts))
  213.     )
  214.   )
  215.   (if masterfl (drawrat))
  216.   (redraw)
  217.   (setvar "CMDECHO" cmdecho)
  218.   (setq *error* olderr)
  219.   (princ)
  220. )
  221.  
  222.