home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
x
/
xshp.zip
/
XSHP.LSP
< prev
Wrap
Text File
|
1991-01-10
|
16KB
|
600 lines
;
;Xshp.lsp
; Explodes text or shapes into plines by reading .shp file.
; Xshp can explode any text or shape entity except ones from a Big Font.
; Including ones with widths, oblique angles, thicknesses, under/over-scores
; and other special char's. Entity layers and colors are ignored.
;
; Note: Xshp assumes the .shp file can be found in the same subdirectory
; as the .shx file. If an entity has a width or oblique angle, its
; arc segments are broken into lines. The # of lines produced is
; controlled by system variable SplineSegs. For my purposes, it is
; the number of line segments in a 45 degree arc.
;
; Copyright 1990,91 by Upper Canada Software
; written by: Len Switzer
; 76207,254
;
;New *ERROR* routine.
(defun ShpErr(Str)
(if ShpFH(setq ShpFH(close ShpFH)))
(setq SS nil *error* OldErr OldErr nil)
(SysVar nil nil)
(gc)
(if(/= Str"quit / exit abort")
(princ(strcat"\n oops... ERROR: "Str)))
(command)
(princ))
;Displace Point.
;Set new current point and pass to acad if pen is down.
(defun DispPt(Pt)
(setq Pt(mapcar '*
Pt
(list(* Scale Width)Scale))
Pt(mapcar
'(lambda(Sym Pt1 Pt2)
(apply Sym (list Pt1 Pt2)))
Gen
CurPt
(list(+(car Pt)(* OblTan(cadr Pt)))
(cadr Pt))))
(if(null Rel10)
(setq Pt(polar CurPt
(cdr(assoc 50 Ent))
(distance CurPt Pt))))
(if PenDn
(command Pt)
(grdraw CurPt Pt -1))
(setq CurPt Pt))
(defun Arc( / Dist Ang Cnt1 Cnt2 Pt1 Pt2)
(setq Center(polar '(0 0) (+ Ang1 pi) Radius))
(if(and(zerop OblTan)(eq Width 1.0))
(if PenDn
(progn
(command "A" "CE")
(if(eq Ang1 Ang2)
(progn
(DispPt Center)
(DispPt Center)
(command "CE")
(setq Ang1(- Ang1 pi))))
(DispPt (polar '(0 0) (+ Ang1 pi) Radius))
(DispPt (polar '(0 0) Ang2 Radius))
(command "L"))
(DispPt(polar Center Ang2 Radius)))
(progn
(if(and(zerop Count)
(equal Ang1 Ang2 1.0e-9))
(setq Cnt1(* pi 2))
(setq Dist(/(distance(polar Center Ang1 Radius)
(polar Center Ang2 Radius))
2)
Ang(*(atan Dist
(sqrt(-(expt Radius 2)(expt Dist 2))))
2)
Cnt1(if(equal(polar Center Ang2 Radius)
(polar Center
(apply(if Sign '- '+)(list Ang1 Ang))
Radius)
1.0e-6)
Ang
(-(* pi 2)Ang))
Cnt1(if Sign
(*(abs Cnt1)-1)
(abs Cnt1))))
(setq Cnt2(1+(fix(*(/(abs Cnt1)(/ pi 4))(getvar"SplineSegs"))))
Cnt1(/ Cnt1 Cnt2)
Pt1'(0.0 0.0))
(repeat Cnt2
(DispPt(mapcar'-
(setq Pt2(polar Center(setq Ang1(+ Ang1 Cnt1))Radius))
Pt1))
(setq Pt1 Pt2)))))
(defun Bulge( / Dist Hgt)
(setq Temp(car ShpLst)
ShpLst(cdr ShpLst)
Sign(minusp Temp)
Temp(abs Temp)
Count 1)
(if(or(zerop Temp)(null PenDn))
(DispPt(list X Y))
(progn
(setq Dist(distance '(0 0)(list X Y))
Hgt(/(* Dist Temp)254)
Center(polar(list(/ X 2.0)(/ Y 2.0))
(apply(if Sign '-'+)
(list(angle'(0 0)(list X Y))
(/ pi 2)))
(/(-(expt Dist 2)(*(expt Hgt 2)4))(* Hgt 8)))
Ang1(angle Center '(0 0))
Ang2(angle Center(list X Y))
Radius(distance Center'(0 0)))
(command "A" "D"
(*(/(apply(if Sign '-'+)
(list(angle Center'(0 0))
(/ pi 2)))
pi)180))
(DispPt(list X Y))
(command "L"))))
;SysVar is used to save, set & restore system variables.
;Uses global SysLst to store values.
; (SysLst <Sys.Var.> <New Setting>) - Set <Sys.Var.> to <New Setting>.
; Old value will be stored in SysLst only if there is no previous value.
; (SysLst <Sys.Var.> nil) - Restore <Sys.Var.> to old value.
; (SysLst nil nil) - Restore all settings.
(defun SysVar(Sym Mode)
(cond
(Mode
(if(assoc Sym SysLst)
(if(null(cdr(assoc Sym SysLst)))
(setq SysLst(subst(cons Sym(getvar Sym))(cons Sym nil)SysLst)))
(setq SysLst(cons(cons Sym(getvar Sym))SysLst)))
(setvar Sym Mode))
(Sym
(if(and(setq Mode(assoc Sym SysLst))(cdr Mode))
(progn(setvar Sym(cdr Mode))
(setq SysLst(subst(cons Sym nil)Mode SysLst)))))
(T(foreach Mode SysLst
(if(cdr Mode)(setvar(car Mode)(cdr Mode))))
(setq SysLst nil))))
;Parse a number from .SHP file. Convert from hex if needed.
(defun Get#( / Sign #Str Cnt Sum NumBit)
(setq Cnt 1)
(while(not(member(substr Str(setq Cnt(1+ Cnt))1)
(list","""))))
(setq #Str(substr Str 1(1- Cnt))
Str(substr Str(1+ Cnt)))
(if(eq Str"")
(if(setq Str(read-line ShpFH))
(setq Str(strcase Str))))
(if(eq(ascii #Str)40) ;Left bracket?
(setq #Str(substr #Str 2)))
(if(eq(substr #Str(strlen #Str))"\051");Right bracket?
(setq #Str(substr #Str 1(1-(strlen #Str)))))
(if(eq(ascii #Str)45) ;Negative?
(setq #Str(substr #Str 2)Sign"-")(setq Sign""))
(if(and(eq(ascii #Str)48) ;Hex number?
(>(strlen #Str)1))
(progn
(setq #Str(substr #Str 2)Sum 0 NumBit(*(1-(strlen #Str))4))
(while(/= #Str"")
(setq Sum(+ Sum
(*(-(ascii #Str)(if(<(ascii #Str)58)48 55))
(expt 2 NumBit)))
#Str(substr #Str 2)NumBit(- NumBit 4)))
(if(eq Sign"")Sum(* Sum -1)))
(atoi(strcat Sign #Str))))
(defun DrawScore(Pt1 Pt2 Mode)
(command)
(command ".Pline")
(setq CurPt(list Pt1 0)PenDn T)
(DispPt(list(/(*(cdr(assoc 40 Ent))-0.15)Scale)
(/(*(cdr(assoc 40 Ent))(if Mode 1.2 -0.2))Scale)))
(setq CurPt(list Pt2 0))
(DispPt(list(/(*(cdr(assoc 40 Ent))-0.15)Scale)
(/(*(cdr(assoc 40 Ent))(if Mode 1.2 -0.2))Scale)))
(command""))
(defun FindShp()
(or
(setq ShpFH(open(strcat(cdr(assoc 3 Style))".shp")"r"))
(and
(setq Str(getvar"AcadPrefix"))
(while(/= Str"")
(setq Cnt 0)
(while
(not(member(substr Str(setq Cnt(1+ Cnt))1)
'(";" ""))))
(setq Str(if(setq ShpFH(open(strcat(substr Str 1(1- Cnt))
(cdr(assoc 3 Style))".shp")
"r"))
""
(substr Str(1+ Cnt)))))
(cond
(ShpFH)
((and Rel10
(setq Str(findfile(strcat(cdr(assoc 3 Style))".shp"))))
(setq ShpFH(open Str"r")))))))
;Reads .shp file & returns list of shape cmds for Char.
;Assumes Ent is set to text or shape entity.
(defun GetShp(Char / ShpFH ShpLst Str Cnt)
(if(or(eq(cdr(assoc 0 Ent))"TEXT")
(numberp Char))
(if(or Style
(and
(setq Style(tblsearch"Style"(cdr(assoc 7 Ent))))
(FindShp)
(progn
(while(and(setq Str(read-line ShpFH))
(/=(atoi(substr Str 2))0)))
Str)
(setq Str(strcase(read-line ShpFH)))
(null(setq Above(Float(Get#))
Vert(eq(logand(cdr(assoc 70 Style))4)4)
ShpFH(close ShpFH)))))
(progn
(FindShp)
(while
(and
(progn(while(and(setq Str(read-line ShpFH))
(/=(ascii Str)42))) ;*
Str)
(setq Str(strcase(substr Str 2)))
(princ" \r")
(/=(princ(Get#))Char)))
(if(null Str)
(princ(strcat"\n**Character \042"(chr Char)"\042 not found in "
(strcase(cdr(assoc 3 Style)))".SHP"))))
(cond
((null ScrFH)
(princ(strcat"\n**Can't open "(strcase(cdr(assoc 3 Style)))".SHP"))
(setq Style nil))
((null Str)
(princ(strcat"\n**Can't find \042*0\042 character in "
(strcase(cdr(assoc 3 Style)))".SHP"))
(setq Style nil))))
(progn
(setq Style(tblnext"Style"T)Above 1.0)
(while
(and
(progn
(while
(and
(or(zerop(logand(cdr(assoc 70 Style))1))
(eq(cdr(assoc 3 Style))""))
(setq Style(tblnext"Style"))))
Style)
(FindShp)
(while
(and
(progn
(while(and(setq Str(read-line ShpFH))(/=(ascii Str)42)))
Str)
(setq Cnt 2)
(progn
(while(not(member(substr Str(setq Cnt(1+ Cnt))1)
'(","""))))
T)
(setq Str(substr Str(1+ Cnt))
Cnt 0)
(progn
(while(not(member(substr Str(setq Cnt(1+ Cnt))1)
'(","""))))
T)
(princ" \r")
(/=(princ(strcase(substr Str(1+ Cnt))))
(cdr(assoc 2 Ent)))))))
(cond
((null Style)
(princ(strcat"\n**Shape "(cdr(assoc 2 Ent))
" not found in shape files.")))
((null ShpFH)
(princ(strcat"\n**Can't open "(strcase(cdr(assoc 3 Style)))".SHP"))))))
(if(and Style ShpFH)
(progn
(setq Cnt(Get#)
Str(strcase(read-line ShpFH))
Scale(/(cdr(assoc 40 Ent))Above))
(repeat(1- Cnt)
(setq ShpLst(cons(Get#)ShpLst)))
(setq ShpFH(close ShpFH))
(reverse ShpLst))
(progn
(entdel(cdr(assoc -1 Ent)))
(if ShpFH
(setq ShpFH(close ShpFH))))))
;Main routine.
;Draws a pline copy of Char.
(defun DrawShp(Char / ShpLst PenDn Byte Temp Temp1 X Y Center
Radius Ang1 Ang2 Sign Count)
(setq ShpLst(GetShp Char)
PenDn T)
(command)
(command".Pline"CurPt)
;Loop for each command in shape definition.
(while ShpLst
(setq Byte(car ShpLst)
ShpLst(cdr ShpLst))
(if(> Byte 15)
;Length and direction in one byte.
(progn
(setq Temp(rem Byte 16);Direction
Temp1(lsh Byte -4);Length
X(* Temp1(nth Temp(list 1.0 1.0 1.0 0.5 0.0 -0.5 -1.0 -1.0
-1.0 -1.0 -1.0 -0.5 0.0 0.5 1.0 1.0)))
Y(* Temp1(nth Temp(list 0.0 0.5 1.0 1.0 1.0 1.0 1.0 0.5 0.0
-0.5 -1.0 -1.0 -1.0 -1.0 -1.0 -0.5))))
(DispPt(list X Y)))
;Byte is a shape command from 0 to 14.
;Nth finds corresponding code much quicker than a big cond test.
((nth Byte(list
;0 End of shape
(lambda()
(command))
;1 Pen down
(lambda()
(setq PenDn T)
(command)
(command".Pline"CurPt))
;2 Pen up
(lambda()
(setq PenDn nil)
(command))
;3 Divide scale
(lambda()
(setq Scale(/ Scale(car ShpLst))
ShpLst(cdr ShpLst)))
;4 Multiply scale
(lambda()
(setq Scale(* Scale(car ShpLst))
ShpLst(cdr ShpLst)))
;5 Push current location
(lambda()
(setq Stack(cons CurPt Stack)))
;6 Pop location
(lambda()
(if Stack
(progn
(setq CurPt(car Stack)Stack(cdr Stack))
(if PenDn(progn(command)(command".Pline"CurPt))))
(princ"\n**More pops than pushes.")))
;7 Draw subshape. Save current data, recursively draw subshape.
(lambda()
(setq Temp(car ShpLst)
Temp1(cdr ShpLst))
(princ" subshape:\n")
(DrawShp Temp)
(setq ShpLst Temp1))
;8 XY displacement
(lambda()
(setq X(car ShpLst)Y(cadr ShpLst)
ShpLst(cddr ShpLst))
(DispPt(list X Y)))
;9 Multiple XY displacements
(lambda()
(while(not
(and
(progn
(setq X(car ShpLst)Y(cadr ShpLst)ShpLst(cddr ShpLst))
T)
(zerop X)
(zerop Y)))
(DispPt(list X Y))))
;10 Octant arc
(lambda()
(setq Radius(car ShpLst)
Ang1(cadr ShpLst)
Sign(minusp Ang1)
ShpLst(cddr ShpLst)
Count(rem(abs Ang1)16)
Ang1(*(/(abs Ang1)16)(/ pi 4))
Ang2(if(zerop Count)
Ang1
(apply(if Sign '- '+)
(list Ang1(* Count(/ pi 4))))))
(Arc))
;11 Fractional arc
(lambda()
(setq Temp(car ShpLst) ;Start offset.
Temp1(cadr ShpLst) ;End offset.
Radius(+(*(caddr ShpLst)256)(cadddr ShpLst))
ShpLst(cddddr ShpLst)
Ang1(car ShpLst) ;Start octant/Count.
ShpLst(cdr ShpLst)
Sign(minusp Ang1)
Temp(/(* Temp 45.0)256)
Temp1(/(* Temp1 45.0)256)
Count(rem(abs Ang1)16)
Ang1(*(/(abs Ang1)16)(/ pi 4))
Ang2(if(zerop Count)
(if(equal Temp Temp1 1.0e-9)
Ang1
(apply
(if Sign '+ '-)
(list Ang1(/ pi 4))))
(apply(if Sign '-'+)
(list Ang1
(*(1- Count)(/ pi 4)))))
Ang1(apply(if Sign '-'+)
(list Ang1(*(/ Temp 180)pi)))
Ang2(apply(if Sign '-'+)
(list Ang2(*(/ Temp1 180)pi))))
(Arc))
;12 Bulge arc
(lambda()
(setq X(car ShpLst)Y(cadr ShpLst)
ShpLst(cddr ShpLst))
(Bulge))
;13 Multiple bulge arcs
(lambda()
(while(not(and(setq X(car ShpLst)Y(cadr ShpLst))
(progn(setq ShpLst(cddr ShpLst))T)
(zerop X)(zerop Y)))
(Bulge)))
;14 Vertical command. If text isn't vertical, skip next command.
(lambda()
(if(null Vert)
(cond
((null(setq Byte(car ShpLst)ShpLst(cdr ShpLst))))
((member Byte(list 3 4 7))
(setq ShpLst(cdr ShpLst)))
((member Byte(list 8 10 12))
(setq ShpLst(cddr ShpLst)))
((eq Byte 11)
(setq ShpLst(cddddr ShpLst)))
((member Byte(list 9 13))
(while(and(setq X(car ShpLst))(setq Y(cadr ShpLst))
(setq ShpLst(cddr ShpLst))
(not(and(zerop X)(zerop Y))))
(if(eq Byte 13)
(setq ShpLst(cdr ShpLst))))))))
;15 Illegal cmd. This should never be found.
(lambda()))))))
(if ShpFH
(setq ShpFH(close ShpFH))))
;Start of routine.
(defun C:XShp( / SS OldErr Ent Stack Width OlbTan Gen Score Style Rel10
CurPt Text Char Cnt Str Lst Pt Pt1 Scale Above Vert)
(princ"\nSelect text and shapes to explode.")
(setq SS(ssget)
Rel10(>=(atof(getvar"AcadVer"))10.0)
OldErr *error*
*error* ShpErr)
(SysVar"CmdEcho"0)
(SysVar"BlipMode"0)
(SysVar"GridMode"0)
;Loop for each entity selected.
(while(progn
;Prune out unwanted entities.
(while(cond
((null(setq Ent(ssname SS 0)))
nil)
((not(member(cdr(assoc 0(setq Ent(entget Ent))))
(list"TEXT""SHAPE")))))
(ssdel(cdr(assoc -1 Ent))SS))
Ent)
(ssdel(cdr(assoc -1 Ent))SS)
(setq Width(cdr(assoc 41 Ent))
OblTan(/(sin(cdr(assoc 51 Ent)))(cos(cdr(assoc 51 Ent))))
Gen(if(assoc 71 Ent)
(list(if(eq(logand(cdr(assoc 71 Ent))2)2) '- '+)
(if(eq(logand(cdr(assoc 71 Ent))4)4) '- '+))
'(+ +))
Stack nil
Score nil
Style nil)
;Set start point and UCS if Release 10, and thickness.
(if Rel10
(progn(setq CurPt'(0.0 0.0))
(command)(command".ucs""e"(cdr(assoc -1 Ent))))
(setq CurPt(cdr(assoc 10 Ent))))
(entdel(cdr(assoc -1 Ent)))
(SysVar"Thickness"
(if(assoc 39 Ent)
(cdr(assoc 39 Ent))
0.0))
(if(eq(cdr(assoc 0 Ent))"TEXT")
(progn
(setq Text(cdr(assoc 1 Ent)))
;Loop for each character.
(while(/= Text"")
(princ"\n")
(if(eq(substr Text 1 2)"%%")
(progn
(setq Char(strcase(substr Text 3 1))
Text(substr Text 4))
(if(member Char '("O""U""D""P""C""%"))
(cond
((eq Char"O")
(setq Score(cons(cons T(car CurPt))Score)
Char nil))
((eq Char"U")
(setq Score(cons(cons nil(car CurPt))Score)
Char nil))
((eq Char"%")
(setq Char 37))
((setq Char(cadr(assoc Char'(("D" 127)("P" 128)("C" 129)))))))
(progn
(setq Str ""
Text(strcat Char Text)
Cnt 1)
(while(and(< Cnt 4)
(not(zerop(setq Char(ascii(substr Text Cnt 1)))))
(> Char 47)(< Char 58))
(setq Str(strcat Str(chr Char))
Cnt(1+ Cnt)))
(setq Text(substr Text Cnt)
Char(atoi Str))
(if(zerop Char)
(setq Text(substr Text 2)
Char nil))))
(if Char
(DrawShp Char)))
(progn
(DrawShp(ascii Text))
(setq Text(substr Text 2)))))
(if Score
(progn
(setq Lst'(nil nil)Pt1 CurPt)
(foreach Pt Score
(setq CurPt Pt1)
(if(car Pt)
(if(car Lst)
(progn
(DrawScore(car Lst)(cadr Pt)T)
(setq Lst(list nil(cadr Lst))))
(setq Lst(list(cdr Pt)(cadr Lst))))
(if(cadr Lst)
(progn
(DrawScore(cadr Lst)(cadr Pt)nil)
(setq Lst(list(car Lst)nil)))
(setq Lst(list(car Lst)(cdr Pt))))))
(setq CurPt Pt1)
(if(car Lst)
(DrawScore(car Lst)(car CurPt)T))
(setq CurPt Pt1)
(if(cadr Lst)
(DrawScore(cadr Lst)(car CurPt)nil)))))
;Pass shape name, not ascii number.
(DrawShp(cdr(assoc 2 Ent))))
(command)
(if Rel10
(command".ucs""p")))
;Use *Error* to close ShpFH and tidy up memory.
(ShpErr"quit / exit abort"))