home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
autocad
/
makelt.arj
/
MAKELT.LSP
Wrap
Lisp/Scheme
|
1991-06-03
|
15KB
|
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)
