Liren Large Software Subsidy 13/13.iso/p/p024/5.img/R11SUPP.EXE/MFACE.LSP

Lisp/Scheme | 1990-08-01 | 6.1 KB | 214 lines

;;;   MFACE.LSP
;;;   Copyright (C) 1990 by Autodesk, Inc.
;;;
;;;   Permission to use, copy, modify, and distribute this software and its
;;;   documentation for any purpose and without fee is hereby granted.
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;--------------------------------------------------------------------------
;;; DESCRIPTION
;;;   C:MFACE -- Pmesh creator.
;;;
;;;   This routine is a front end to the PFACE
;;;   command in AutoCAD.  It allows the user to easily
;;;   create pface meshes at the command prompt.

;;;   Training Department / J.F.
;;;   5/04/90
;;;
;;;----- Redefined error function ----------------------------

(defun newerr (s)
  (if (/= s "Function cancelled")
      (princ (strcat "\nError: " s))
  )
  (setq *error* olderr)
  (setvar "CMDECHO" cmdecho)
  (redraw)
  (princ)
)

;;;
;;;----- Draw PFACE ----------------------------------------
;;;
(defun drawrat ()
  (command "PFACE")
  (while (car vlist)
    (command (car vlist))
    (setq vlist (cdr vlist))
  )
  (command "")
  (while (setq facelist (car masterfl))
    (command "color" (car colorlst))
    (command "layer" (car layerlst))
    (while (car facelist)
           (command (car facelist))
           (setq facelist (cdr facelist))
    )
    (command "")
    (setq layerlst (cdr layerlst))
    (setq colorlst (cdr colorlst))
    (setq masterfl (cdr masterfl))
  )
  (command "")
)

;;;
;;;----- Find current entity color ---------------------------
;;; The system variable "CECOLOR" gives the color number and
;;; the color name (i.e. "1 red") for the first 7 colors.
;;; This function strips the color name and returns the color
;;; number.
;;;
(defun getcolor (/ max ctr cecolor)
  (setq colnam nil)
  (setq cecolor (getvar "CECOLOR"))
  (setq ctr 1)
  (setq max (strlen cecolor))
  (while (< ctr max)
    (if (= (substr cecolor ctr 1) " ")
      (progn
        (setq colnam (substr cecolor 1 (- ctr 1)))
        (setq ctr max)
      )
      (setq ctr (1+ ctr))
    )
  )
  (if (not colnam) (setq colnam cecolor))
)

;;;
;;;----- Prompt for layer, chk table, add to layer list ------
;;;
(defun setlay (/ oldlnam)
  (setq oldlnam laynam)
  (setq laynam
      (getstring (strcat "\nLayer name <" oldlnam ">: "))
  )
  (if (= laynam "")                   ;if accepting default layer name
    (setq laynam oldlnam)             ;then set to default
    (progn                            ;else check layer table
      (while (not (tblsearch "LAYER" laynam))
        (prompt (strcat "\nCannot find layer " laynam))
        (setq laynam
          (getstring (strcat "\nLayer name <" oldlnam ">: "))
        )
        (if (= laynam "") (setq laynam oldlnam))
      )
    )
  )
)
;;;
;;;----- Prompt for color, convert # to string ---------------
;;;
(defun setcol (/ oldcolor)
  (setq oldcolor colnam)
  (initget "Red Blue Green Cyan Byblock Yellow Magenta White Bylayer")
  (setq colnam
    (getint (strcat "\nColor no. <" colnam ">: "))
  )
  (cond
    ((numberp colnam) (setq colnam (itoa colnam)))
    ((equal colnam nil) (setq colnam oldcolor))
  )
)

;;;
;;; ----- Set grdraw color -----------------------------------
;;; This function set the color number for the grdraw function
;;; if GRCOLOR does not contain the color number (i.e. if
;;; set to "red" it would change it to "1").
;;;
(defun subcolor ()
  (cond
    ((equal grcolor "Red")     (setq grcolor 1))
    ((equal grcolor "Yellow")  (setq grcolor 2))
    ((equal grcolor "Green")   (setq grcolor 3))
    ((equal grcolor "Cyan")    (setq grcolor 4))
    ((equal grcolor "Blue")    (setq grcolor 5))
    ((equal grcolor "Magenta") (setq grcolor 6))
    ((equal (strcase grcolor) "BYLAYER") ;find layer color
      (setq laylist (tblsearch "layer" (last layerlst)))
      (setq grcolor (cdr (assoc 62 laylist)))
    )
    ((equal (strcase grcolor) "BYBLOCK") (setq grcolor 7))
    ( T (setq grcolor (atoi grcolor)))
  )
)

;;;
;;;----- Add vertex to face list, find order in list ---------
;;; This function adds the vertex point to the vertex list if
;;; it is not in the vertex list.  Then it finds the order of
;;; the vertex in the list and add it to the face list.
;;;
(defun addpt (/ remain remain-l vlist-l v-order)
  (if (not (setq remain (member pt vlist)))
    (progn
      (setq vlist (append vlist (list pt)))
      (setq remain (member pt vlist))
    )
  )
  (setq remain-l (length remain))
  (setq vlist-l (length vlist))
  (setq v-order (1+ (- vlist-l remain-l)))
  (setq facelist (append facelist (list v-order)))
)

;;;
;;;----- Get vertex, add face list to master face list -------
;;;
(defun getvts (/ grcolor 1st prev-pt)
  (setq layerlst (append layerlst (list laynam)))
  (setq colorlst (append colorlst (list colnam)))
  (setq grcolor colnam ctr 1)
  (if (not (numberp grcolor)) (subcolor))
  (setq prev-pt pt) (setq 1st pt)
  (while (setq pt (getpoint pt "\nSelect Vertex: "))
    (grdraw prev-pt pt grcolor 0)
    (if (> ctr 2)
      (grdraw 1st pt grcolor 1)
    )
    (setq prev-pt pt)
    (addpt)
    (setq ctr (1+ ctr))
  )
  (grdraw prev-pt 1st grcolor 0)
  (setq masterfl (append masterfl (list facelist)))
  (setq facelist nil)
)

;;;
;;;----- Primary function ------------------------------------
;;;
(defun C:MFACE (/ facelist masterfl vlist colorlst layerlst
                   laynam pt)
  (setq olderr  *error*
        *error* newerr
        again   T
        cmdecho (getvar "CMDECHO")
        laynam  (getvar "CLAYER")
  )
  (setvar "CMDECHO" 0)
  (getcolor)
  (while again
    (initget "Color Layer")
    (setq pt (getpoint "\nLayer/Color/<Select vertex>: "))
    (cond
      ((equal pt "Color") (setcol))
      ((equal pt "Layer") (setlay))
      ((not pt) (setq again nil))
      (T (addpt) (getvts))
    )
  )
  (if masterfl (drawrat))
  (redraw)
  (setvar "CMDECHO" cmdecho)
  (setq *error* olderr)
  (princ)
)