Black Box 4/BlackBox.cdr/autocad/makelt.arj/MAKELT.LSP

Lisp/Scheme | 1991-06-03 | 14.6 KB | 935 lines

;;;   MAKELT.lsp

;;;   Copyright (C) 1991 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.

;;;

;;;   by Carl B. Bethea

;;;   29 April 1991

;;;

;;;--------------------------------------------------------------------------;

;;;   DESCRIPTION

;;;

;;;

;;;   MakeLT creates and edits linetypes. The function has four options:

;;;

;;;   Pattern - This option creates lines and points representing the linetype

;;;   definition at an LTSCALE of 1.0. You can then edit this pattern adding

;;;   to it or subtracting from it or changing the components, and then use

;;;   the New option, below, to create a new linetype definition or redefine

;;;   the existing linetype.

;;;

;;;   LTscale - Like Pattern, this option draws lines and points representing

;;;   the linetype definition, but allows you to use an LTSCALE other than

;;;   1.0. This option is useful for creating variations of existing linetypes

;;;   that will then be used at different scales within the drawing.

;;;

;;;   Match - This option is similar to the LTscale option, in as much as it

;;;   uses the current LTSCALE setting to create a new linetype definition.

;;;   The difference is that it does not draw the pattern; instead it writes

;;;   the definiton directly to file.

;;;

;;;   New - This option allows you to select lines and points which represent

;;;   a linetype pattern. The function then calculates the linetype definition

;;;   data, writes that data to the LIN file and then loads the linetype into

;;;   memory. The routine assumes that you have selected a full linetype

;;;   pattern, that is, that the last segment is roughly equal to the first.

;;;   If you look at the definition in the LIN file, you will see that the

;;;   last segment is assumed to be a repeat of the first; so, MakeLT makes

;;;   the same assumtion and automatically throws out the last segment before

;;;   writing the data to file. It's important to select the last segment,

;;;   however, because MakeLT uses it to calculate the pen-up movement for the

;;;   final gap in the pattern.

;;;

;;;   As a side note, one of the more interesting subroutines in this program

;;;   is SYSVAR. It is used to set and reset system variables during the

;;;   running of the program. Instead of using a global variable to store the

;;;   old variables settings, the program employs a unique attribute of the

;;;   LISP programming language. The function redefines itself while it is

;;;   running, and in this way stores the old settings for the system

;;;   variables internally.

;;;

;;;

;;;-- mk_getlt ---------------------------------------------

;;;   find the linetype of an entity

;;;   get the defintion

;;;   spawns: <lname tpl>

;;;

(defun mk_getlt (ent / dxf data)



   (defun dxf (x)(cdr(assoc x data)))



   (setq data (entget ent)

        lname (if (dxf 6)

                  (dxf 6)

                  (progn

                     (setq data (tblsearch "LAYER" (dxf 8)))

                     (dxf 6)

                  )

              )

         data (tblsearch "LTYPE" lname)

          tpl (dxf 40); total pattern length

   )

   (mapcar '(lambda (i)

              (cdr i)

            )

            (member (assoc 49 data) data)

   )

)

;;;

;;;

;;;-- mk_drawlt --------------------------------------------

;;;   draw lines and points to represent the linetype

;;;   (idea: use plines for width)

;;;

(defun mk_drawlt (lts / p1 ent vector i)

   (if (setq ent (entsel "\nPick a example of the linetype: "))

      (progn

         (sysvar "cmdecho" 0)

         (setq ent (car ent)

            vector (mk_getlt ent)

         )

         (if lts

            (setq vector

               (mapcar '(lambda (i)

                           (* i lts)

                        )

                        vector

               )

            )

         )

         (setq vector (append vector (list (car vector))))



         (setq celt (getvar "CELTYPE")

                 p1 (getpoint "\nStart point for pattern: ")

         )

         (command "linetype" "Set" "Continuous" "")

         (foreach i vector

            (cond

               ((minusp i)

                  (setq p1 (polar p1 0 (abs i)))

               )

               ((= 0.0 i)

                  (command "point" p1)

               )

               (T (command "line"

                     p1

                     (setq p1 (polar p1 0 i))

                     ""

                  )

               )

           );cond

         );foreach

         (command "linetype" "Set" CELT "")

         (sysvar "cmdecho" nil)

      );progn

      (prompt " none found.")

   );if

)

;;;

;;;

;;;-- mk_sslist --------------------------------------------

;;;   convert selection-set <SS>

;;;   into a list of entities

;;;

(defun mk_sslist (ss / n p)

   (repeat (setq n (sslength ss))      ;seed n

      (setq n (1- n)                   ;index number

            p (cons (ssname ss n) p)

      )

   )

); mk_sslist

;;;

;;;

;;;-- mk_clean ---------------------------------------------

;;;   sort the vector list

;;;

(defun mk_clean (alist / n i clist)

   (repeat (setq n (length alist))

      (setq i (car  alist))

      (foreach c alist

         (if (> (caar c) (caar i)) (setq i c))

      )

      (setq clist (cons i clist)

            alist (append (cdr (member i (reverse alist))); remove i

                          (cdr (member i alist))          ; from list

                  )

      );setq

   )

   clist

);mk_clean

;;;

;;;

;;;-- mk_getparts ------------------------------------------

;;;   collect the entities of the line defintion

;;;   sort them by start point

;;;

(defun mk_getparts (/ dxf data parts vector)



   (defun dxf (x)(cdr(assoc x data)))



   (prompt "\nSelect lines and points defining a linetype: ")

   (cond

      ((setq parts (ssget))

         (setq parts (mk_sslist parts)

              vector (mapcar

                       '(lambda (i)

                           (setq data (entget i))

                           (cons

                              (dxf 10)

                              (if (dxf 11)

                                  (distance (dxf 10)(dxf 11))

                                  0

                              )

                           )

                        )

                        parts

                     );mapcar

              vector (mk_clean vector)

         );setq

      )

      (T nil)

  )

)

;;;

;;;

;;;-- mk_calpen --------------------------------------------

;;;   calculate the pen movements

;;;   return "pen-down,pen-up" codes

;;;

(defun mk_calpen (v1 v2 / down up)

   (setq

        up (distance

              (polar (car v1) 0 (cdr v1))

              (car v2)

           )

      down (if (= 0 (cdr v1))

              "0"

               (rtos (cdr v1) 2 2)

           )

   )

   (strcat

      down

      ",-"

      (rtos up 2 2)

      ","

   )

)

;;;

;;;

;;;-- mk_deflin --------------------------------------------

;;;   define the linetype

;;;   requires <vector> set by mk_getparts

;;;

(defun mk_deflin (/ i )

   (setq i

      (apply 'strcat

         (mapcar 'mk_calpen

            (reverse (cdr (reverse vector))); everything but the last

            (cdr vector)                    ; everything but the first

         )

      )

   )

   (substr i 1 (1- (strlen i)))             ; take off last comma

)

;;;

;;;

;;;-- sysvar -----------------------------------------------

;;;   change system variable, save old value, reset later

;;;   (sysvar <system variable> <new value>)

;;;   (sysvar "cmdecho" 1) sets a single system variable

;;;   (sysvar '("cmdecho" "blipmode") '(1 0)) multiple variables

;;;   (sysvar <system variable> nil) resets specified variables(s)

;;;   (sysvar nil nil) resets all system variables

;;;

(defun sysvar (what new / sys_var sys_set old sys_unset sys_cond)



   (setq sys_var nil)



   ;; make dotted pair, add it to the front of list.

   (defun sys_set (what new)

      (setq what (strcase what t))



      ;; make sure the same pair is not extant,

      ;; otherwise sys_unset will screw-up the list.

      ;; FILO accounting will reset previous change

      (if (not

             (member

                (cons what (setq old (getvar what)))

                sys_var

             )

          )

          (setq  sys_var

             (cons

                 (cons what old)

                 sys_var

             )

          )

      )

      (setvar what new)

   )



   ;; change setvar to old setting,

   ;; remove the pair from the list

   (defun sys_unset (what)

      (setq what (strcase what t))

      (setvar what

         (cdr (setq old (assoc what sys_var)))

      )

      (setq sys_var

         (append

            (cdr (member old (reverse sys_var))); remove old

            (cdr (member old sys_var))          ; from list

         )

      )

   )



   (defun sys_cond (what new)

   (cond



      ;; if both variables are set

      ;; then set the system variables

      ;; if <what> is not a single string

      ;; then assume it is a list and that

      ;; make sure they are the same length

      ((and what new)

         (if (eq 'STR (type what))

             (sys_set what new)

             (if (= (length what)(length new))

                 (mapcar 'sys_set what new)

                 (prompt "SYSVAR: argument mismatch.\n")

             )

         )

      )



      ;; <new> is not set, but <what> is

      ;; undo the setvar

      ;; if list is not a single string

      ;; assume that it is a list, do all

      ((eq 'STR (type what))

         (sys_unset what)

      )

      (what

         (mapcar 'sys_unset what)

      )



      ;; both arguments are nil

      ;; reset all setvars

      (T

         (foreach old sys_var

            (setvar (car old)(cdr old))

         )

         (setq sys_var nil)

      )

   );cond

   )



   ;; execute the internal function

   (sys_cond what new)



   ;; redefine sysvar to contain the new value

   ;; of the local variable sys_var

   (setq

      sysvar (cons (car sysvar)

               (cons

                   (list 'setq 'sys_var (list 'quote  sys_var))

                   (cddr sysvar)

               )

             )

   )

   sys_var

)

;;;

;;;

;;;-- mk_err -----------------------------------------------

;;; internal error handler

;;;

(defun mk_err (msg)

   (if (/= msg "Function cancelled")

      (princ (strcat "\nError: " s))

      (princ msg)

   )

   (command "linetype" "Set" CELT "")

   (sysvar nil nil)

   (setq *error* olderr olderr nil)

   (princ)

)

;;;

;;;

;;;-- c:makelt ---------------------------------------------

;;; make a linetype definiton from a drawing

;;;

(defun c:makelt (/ fname lname tpl lts line

                   code vector celt)



   (setq olderr *error*

         *error* mk_err

   )



   ;; expert=3 automatically overwrites existing linetype

   (sysvar '("blipmode" "cmdecho" "expert")

           '(   0           1         3   )

   )



   (initget "New Pattern LTscale Match")

   (if (null

          (setq code

             (getkword

   "\nLinetype editor: draw Pattern/draw LTscale/Match ltscale/<New>: "

             )

          )

       )

       (setq code "New")

   )



   (cond

      ((and (= code "New")

            (< 1 (length (setq vector (mk_getparts))) 8)

       )

         (setq line (mk_deflin)

              lname (getstring "\nLinetype name: ")

         )

         (command "linetype" "create"

            lname

            pause ; file

            "MakeLT" ; description

            line  ; write the data

            "load" lname "" ""

         )

      );New

      ((= code "New")

         (prompt "Error: must have between 2 and 12 dash/dots.")

      )

      ((= code "Pattern")

         (mk_drawlt nil)

      )

      ((= code "LTscale")

         (if (null

                (setq lts

                   (getdist

                      (strcat "\nNew LTscale <"

                         (rtos (getvar "ltscale"))

                         ">: "

                      )

                   )

                )

             )

             (setq lts (getvar "ltscale"))

         )

         (mk_drawlt lts)

      )

      ((and (= code "Match")

            (setq vector (entsel "\nPick a line to match: "))

       )

         (setq lts (getvar "ltscale")

            vector (mk_getlt (car vector))

            vector (mapcar '(lambda (i)

                               (strcat

                                  (rtos (* i lts) 2 2)

                                  ","

                               )

                            )

                            vector

                   )

            vector (apply 'strcat vector)

              line (substr vector 1 (1- (strlen vector)))

              lname (getstring

                       (strcat "\nNew name for " lname ": ")

                    )

         )

         (if (and line (/= "" lname))

            (command "linetype" "create"

               lname

               pause ; file

               "MakeLT" ; description

               line  ; vector defintion

               "load" lname "" ""

            )

            (prompt " invalid input.")

         )

      )

      (T (prompt " invalid input."))

   )

   (sysvar nil nil)

   (setq *error* olderr olderr nil)

   (princ)

)

;;;

;;;-- end of file ------------------------------------------

(prompt "\nMakeLT options: ")

(prompt "\nPattern - draw the linetype pattern of a selected line.")

(prompt "\nLTscale - draw the pattern at a specified linetype scale.")

(prompt "\n  Match - create a definiton to match a pattern and scale.")

(prompt "\n    New - select objects which define a new linetype pattern.")

(princ)