home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1993 #2
/
Image.iso
/
cad
/
jul93.zip
/
ISO.LSP
< prev
next >
Wrap
Text File
|
1993-06-21
|
18KB
|
600 lines
; ISO.LSP
; copyright 1993, Trevor Churchill
(REPEAT 3 (PROMPT "\n ")) ; 10 Spaces
(PROMPT " Isometric Routine By Trevor Churchill (c) 1992 \n")
;*****************************************************
; FILENAME : ISO.LSP
; VERSION : 1.00
; NAME : Trevor Churchill
; ADDRESS : Box 991, Kindersley, Saskatchewan S0L 1S0
; DATE : November, 1992
; DESCRIPTION : Converts Arcs,Circles,Lines,Solids & Text To
; Isometric Views. Polylines,Blocks & Dims.
; Must Be Exploded First
; SAMPLE CALL : ISO
;***** Define New Error Handling Routine
(DEFUN *error* (msg / )
(PRINC "error: ")
(PRINC MSG) ;Print Error Message To Screen
(TERPRI) ;LineFeed
(SHUTDOWN) ;Make Sure Everything Is Set To Original Values
)
;**** Define Routine To Setup Initial Variable Settings
(DEFUN SETUP ()
(SETQ NL 0 ; Number Of Lines Redrawn
NC 0 ; Number Of Circles Redrawn
NA 0 ; Number Of Arcs Redrawn
NS 0 ; Number Of Solid Redrawn
NT 0 ; Number Of Text Redrawn
O 0 ; Number Of Other Entities
NewSet (SSadd) ; Make Empty Selection Set
Blip (GETVAR "BlipMode") ; Save Initial Setting In Blip
STxt (GETVAR "TextStyle"); Save Initial Setting In STxt
Snap (GETVAR "OSMode") ; Save Initial Setting In STxt
)
(SETVAR "CmdEcho" 0) ; Turn COMMAND Echo Off
(SETVAR "BlipMode" 0) ; Turn BLIPMODE Off
(SETVAR "OSMode" 0) ; Turn OSNAPS To NONE
;***** If MoveToLayer Hasn't Been Set,
; Set Default to Original
(IF (NOT MoveToLayer)(SETQ MoveToLayer "Original"))
;***** If Iso_View Hasn't Been Set, Set It To Right View
(IF (NOT Iso_View)(SETQ Iso_View "R"))
;***** If Thickness Hasn't Been Set, Set Default To 0
(IF (NOT Thickness)(SETQ Thickness 0.0))
)
;***** Setup Layer Information
(DEFUN Setup_Layer ( / Ans)
;***** Get Information On Which Layer To Put
; Original Entities
(SETQ Ans (GETSTRING
(STRCAT
"\nWhich Layer To Put Original Entities On?<"
MoveToLayer
">"
)
)
)
(IF (= Ans "")(SETQ Ans MoveToLayer))
(SETQ MoveToLayer Ans)
(IF (NOT (TBLSEARCH "LAYER" MoveToLayer))
; Does The Layer Exist?
(COMMAND "LAYER" "N" MoveToLayer "")
; Doesn't Exist, Create!
)
;***** Get Information On Whether To Give
; View A Thickness Or Not
(SETQ Ans (GETREAL (STRCAT
"\nEnter Thickness Of View <"
(RTOS Thickness)
">"
)
)
)
(IF (= Ans NIL)(SETQ Ans Thickness))
(SETQ Thickness Ans)
)
;***** Get Entitiy Selection Set From User
(DEFUN GET_ENTITIES ( / Base_Point)
(PROMPT
"\nArcs,Circles,Lines,Solids & Text Will Be Processed!!")
(PROMPT
"\nPlease Select Entities To Change To Isometric....")
(SETQ SELSET (SSGET));Get Selection Set From User
(SETQ
Base_Point (GETPOINT
"\nPick A BasePoint For The Iso Figure:(Lower Left-Hand Corner)")
BPX (CAR Base_Point) ; Extract X Value From Base Point
BPY (CADR Base_Point) ; Extract Y Value From Base Point
)
)
;***** Ask User Which Isometric View Should Be Used
(DEFUN Which_View ( / Ans)
(TERPRI) ; Print Blank Line
(INITGET "L R TR") ; Choices = Left,Right,Top R and Nil
(SETQ Ans (GETKWORD ; Get Answer From User
(STRCAT
"Which Isometric View? : "
"L-Left;R-Right;TR-Top Right <"
Iso_View
">"
)
)
)
(IF (= Ans NIL)(SETQ Ans Iso_View))
(SETQ Iso_View Ans)
;***** Set Up Depths For Creating Thicknesses
(SETQ DepthAngle 270)
(If (= Iso_View "R")(SETQ DepthAngle 150))
(If (= Iso_View "L")(SETQ DepthAngle 30))
(SETQ Depth (STRCAT "@" (RTOS Thickness) "<" (RTOS DepthAngle)))
)
;***** Pick Out Entities From Selection Set And Change To Iso
(DEFUN Change_To_Iso ( / EntName EntData EntType SL Index Flag)
(PROMPT "\nWorking.....\n\n")
; Copy Original To Specified Layer If Different
; From Current Layer
(IF (/= MoveToLayer (GETVAR "CLAYER"))
(COMMAND "CHANGE" SelSet "" "P" "Layer" MoveToLayer "")
)
(SETQ SL (SSLENGTH SelSet)) ; Get Length Of Sel. Set
(SETQ Index 0) ; Set Index to 0
(WHILE (< Index SL) ; Loop Until End Of SelSet
(SETQ FLAG 0)
(SETQ EntName (SSNAME SelSet Index)) ; Get Indexed Entity Name
(SETQ EntData (ENTGET EntName)) ; Get Entity Data
(SETQ EntType (CDR (ASSOC 0 EntData))) ; Extract Type
;***** Check For Entity Types And Call Proper Routine
(IF (= EntType "LINE")(Line_Extract_Draw))
(IF (= EntType "CIRCLE")(Circle_Extract_Draw))
(IF (= EntType "ARC")(Arc_Extract_Draw))
(IF (= EntType "TEXT")(Text_Extract_Draw))
(IF (= EntType "SOLID")(Solid_Extract_Draw))
(IF (= FLAG 0)
(PROGN
(PROMPT
"\nBlocks, Dimensions & PolyLines Must Be Exploded!")
(PROMPT "\nWorking.....")
(SETQ O (+ O 1)) ; Increment Other Count
)
)
(SETQ Index (+ Index 1)) ; Increment Index
)
;*************************
; IF There is A Thickness Copy Entities To Show Thickness
(IF (> Thickness 0)
(COMMAND "COPY" NewSet "" "0,0" Depth)
)
)
;Define Routine To Extract Data From Entities Then Draw Entity
;***** In Isometric View! -- ARC
(DEFUN ARC_Extract_Draw ( / Center Radius StartAng EndAng
First Second PickOne PickTwo Temp Temp1 TrimLines )
(SETQ NA (+ NA 1) ; One More Is Processed!
FLAG 1
)
(SETQ Center (CDR (ASSOC '10 EntData)) ; Center Of Arc
Radius (CDR (ASSOC '40 EntData)) ; Radius of Arc
StartAng (CDR (ASSOC '50 EntData)); Starting Angle
EndAng (CDR (ASSOC '51 EntData)) ; Ending Angle
)
;***** Calculate Trim Line End Points!
(SETQ First (POLAR Center StartAng (* 1.2 Radius)))
(Calc_Point First)(SETQ First New_Point)
(SETQ Second (POLAR Center EndAng (* 1.2 Radius)))
(Calc_Point Second)(SETQ Second New_POINT)
;***** Calculate Trim Pick Points!
(SETQ PickOne (POLAR Center (- StartAng (DTR 10)) Radius))
(Calc_Point PickOne)(SETQ PickOne New_Point)
(SETQ PickTwo (POLAR Center (+ EndAng (DTR 10)) Radius))
(Calc_Point PickTwo)(SETQ PickTwo New_Point)
;***** Calculate Isometric Center Point
(Calc_Point Center)(Setq Center New_Point)
(SETQ Temp (GETVAR "SnapIsoPair")) ; Get Initial Iso Vars.
(SETQ Temp1 (GETVAR "SnapStyl"))
(SETVAR "SnapStyl" 1) ; Set To Isometric
;***** Set To Proper View
(IF (= Iso_View "L")(SETVAR "SnapIsoPair" 0))
(IF (= Iso_View "TR")(SETVAR "SnapIsoPair" 1))
(IF (= Iso_View "R")(SETVAR "SnapIsoPair" 2))
(COMMAND "ELLIPSE" "I" Center Radius) ; Draw Iso-Circle
(SETVAR "SnapIsoPair" Temp) ; Revert To Original
(SETVAR "SnapStyl" Temp1) ; Isometric Values
(COMMAND "PLINE" First Center Second "") ; Draw Trim Lines
(SETQ TrimLines (ENTLAST))
(COMMAND "TRIM" TrimLines "" PickOne PickTwo "") Trim Circle
(SETQ NewSet (SSADD (ENTLAST) NewSet)) ; Add It To NewSet
(COMMAND "ERASE" TrimLines "") ; Erase Trim Lines
(PROMPT "\nWorking.....\n\n")
)
;**** Define Routine To Extract Data From Entities
; Then Draw Entity
;**** In Isometric View! -- LINE
(DEFUN Line_Extract_Draw ( / Start End)
(SETQ NL (+ NL 1)) ; One More Line Is Processed!
(SETQ FLAG 1)
(SETQ Start (CDR (ASSOC 10 EntDATA)) ; Extract Start Point
End (CDR (ASSOC 11 EntDATA)) ; Extract End Point
)
;********** Recalculate Start Point
(Calc_Point Start)
(SETQ Start New_Point)
;********** Recalculate End Point
(Calc_Point End)
(SETQ End New_Point)
;********** Draw New Line In Isometric
(COMMAND "LINE" Start End "")
(SETQ NewSet (SSADD (ENTLAST) NewSet)) ; Add It To NewSet
;********** Add Depth Thickness Line If Thickness Is Set
(IF (> Thickness 0)
(PROGN
(COMMAND "LINE" Start Depth "")
(COMMAND "LINE" End Depth "")
)
)
)
;***** Define Routine To Extract Data From Entities
; Then Draw Entity
;***** In Isometric View! -- CIRCLE
(DEFUN Circle_Extract_Draw ( / Temp Temp1 Center Radius Ang Cen
L1 L2 Depth1 Depth2 PP1 PP2)
(SETQ NC (+ NC 1)) ; One More Processed!
(SETQ FLAG 1)
(SETQ Center (CDR (ASSOC '10 EntData)) ; Get Center Point
Cen Center ; Store It Also In Cen
Radius (CDR (ASSOC '40 EntData)) ; Get Circle Radius
)
(Calc_Point Center)(SETQ Center New_Point)
; Calculate New Center
(SETQ Temp (GETVAR "SnapIsoPair"))
(SETQ Temp1 (GETVAR "SnapStyl"))
(SETVAR "SnapStyl" 1) ; Set To Isometric Grid
(IF (= Iso_View "L") ; Set To Proper View, Top,Left Or Right
(SETVAR "SnapIsoPair" 0)
)
(IF (= Iso_View "TR")
(SETVAR "SnapIsoPair" 1)
)
(IF (= Iso_View "R")
(SETVAR "SnapIsoPair" 2)
)
(COMMAND "ELLIPSE" "I" Center Radius)
(SETQ Circle (ENTLAST))
;***** If Thickness Set, Draw Depth Lines
(IF (/= Thickness 0)
(PROGN
(IF (= Iso_View "R")(SETQ LineAng1 45
LineAng2 225
TrimAng1 40
TrimAng2 230
)
)
(IF (= Iso_View "L")(SETQ LineAng1 135
LineAng2 315
TrimAng1 140
TrimAng2 310
)
)
(IF (= Iso_View "TR")(SETQ LineAng1 135
LineAng2 315
TrimAng1 130
TrimAng2 320
)
)
(SETQ Depth1 (POLAR Cen (DTR LineAng1) Radius))
(Calc_Point Depth1)(SETQ Depth1 New_Point)
(SETQ Depth2 (POLAR Cen (DTR LineAng2) Radius))
(Calc_Point Depth2)(SETQ Depth2 New_Point)
(COMMAND "LINE" Depth1 Depth "")(SETQ L1 (ENTLAST))
(COMMAND "LINE" Depth2 Depth "")(SETQ L2 (ENTLAST))
(COMMAND "COPY" Circle "" "0,0" Depth)
(SETQ PP1 (POLAR Cen (DTR TrimAng1) Radius))
(Calc_Point PP1)(SETQ PP1 New_Point)
(SETQ PP2 (POLAR Cen (DTR TrimAng2) Radius))
(Calc_Point PP2)(SETQ PP2 New_Point)
(SETQ PP1 (POLAR PP1 (DTR DepthAngle) Thickness))
(SETQ PP2 (POLAR PP2 (DTR DepthAngle) Thickness))
(COMMAND "TRIM" L1 L2 "" PP1 PP2 "")
)
)
(SETVAR "SnapIsoPair" Temp)
(SETVAR "SnapStyl" Temp1)
)
;***** Define Routine To Extract Data From Entities
; Then Draw Entity
;***** In Isometric View! -- SOLID
(DEFUN SOLID_Extract_Draw ( / P10 P11 P12 P13)
(SETQ NS (+ NS 1)) ; One More Solid Is Processed!
(SETQ FLAG 1)
(SETQ P10 (CDR (ASSOC '10 EntData))) ; Get 1st Point
(Calc_Point P10)(SETQ P10 New_Point)
(SETQ P11 (CDR (ASSOC '11 EntData))) ; Get 2nd Point
(Calc_Point P11)(SETQ P11 New_Point)
(SETQ P12 (CDR (ASSOC '12 EntData))) ; Get 3rd Point
(Calc_Point P12)(SETQ P12 New_Point)
(SETQ P13 (CDR (ASSOC '13 EntData))) ; Get 4th Point
(Calc_Point P13)(SETQ P13 New_Point)
(COMMAND "SOLID" P10 P11 P12 P13 "")
(SETQ NewSet (SSADD (ENTLAST) NewSet))
)
;***** Define Routine To Extract Data From Entities
; Then Draw Entity
;***** In Isometric View! -- TEXT
(DEFUN TEXT_Extract_Draw ( / TxtStrg Insert TxtHgt TxtStyl Align
TD ITxtStyl IOblAngl IAlign)
(SETQ NT (+ NT 1)) ; One More Text Is Processed!
(SETQ FLAG 1)
; If ISO Style Isn't Current, Change To Style ISO
(IF (/= (GETVAR "TextStyle") "ISO")
(PROGN
(COMMAND "STYLE" "ISO" ; Change To Iso Style Text
"TXT" ; Font File
"0" ; Height
"1.00" ; Width
"0" ; Obliquing Angle
"N" ; BackWards?
"N" ; Upside Down?
"N" ; Vertical?
)
(PROMPT "\nWorking.....\n\n")
)
)
(SETQ TxtStrg (CDR (ASSOC '1 EntData)) ; Get String Data
Insert (CDR (ASSOC '10 EntData)) ; Get Insertion Point
TxtHgt (CDR (ASSOC '40 EntData)) ; Get Text Height
TxtStyl (ASSOC '7 EntData) ; Get String Style
Align (ASSOC '72 EntData) ; Get Alignment Data
)
(Calc_Point Insert)(SETQ Insert New_Point)
; ReCalc Insertion PNT
(IF (= Iso_View "L")
(PROGN (SETQ TxtAng "330")(SETQ OblAng
(CONS '51 (DTR 330))))
)
(IF (= Iso_View "TR")
(PROGN (SETQ TxtAng "30")(SETQ OblAng (CONS '51
(DTR 330))))
)
(IF (= Iso_View "R")
(PROGN (SETQ TxtAng "30")(SETQ OblAng (CONS '51
(DTR 30))))
)
(COMMAND "TEXT" Insert TxtHgt TxtAng TxtStrg)
; Draw Initial Text
(SETQ NewSet (SSADD (ENTLAST) NewSet)) ; Add It To NewSet
(SETQ TD (ENTGET (ENTLAST)) ; Get Text Data
ITxtStyl (ASSOC '7 TD) ; Get String Style
IOblAng (ASSOC '51 TD) ; Get Obliquing Angle
IAlign (ASSOC '72 EntData) ; Get Alignment Data
)
(SETQ TD (SUBST TxtStyl ITxtStyl TD) ; Swap Text Style
TD (SUBST Align IAlign TD) ; Swap Alignment
TD (SUBST OblAng IOblAng TD) ; Swap Obliquing
)
(ENTMOD TD) ; Modify It!
)
;***** Change Degrees to Radians!
(DEFUN DTR (a)
(* pi (/ a 180.0))
)
;***** Change Radians to Degrees!
(DEFUN RTD (a)
(* 180.0 (/ a pi))
)
;***** Display Results To User
(DEFUN Display_Results (/)
(REPEAT 2 (TERPRI))
(PROMPT "\nIsometric Results: ")
(PROMPT " Arcs=")(Princ NA)
(PROMPT " Lines=")(Princ NL)
(PROMPT " Circles=")(Princ NC)
(PROMPT " Solid=")(Princ NS)
(PROMPT " Text=")(Princ NT)
(PROMPT " Other=")(Princ O)
(PROMPT "\n ")(PRINC)
)
;**** Define Routine To Restore Initial Variable Settings
(DEFUN SHUTDOWN ()
; If We've Changed Styles, Change It Back!
(IF (= (GETVAR "TextStyle") "ISO")
(COMMAND "STYLE" STXT "" "" "" "" "" "" "")
)
(SETVAR "BlipMode" Blip) ; Revert To Original Setting
(SETVAR "OSMode" Snap) ; Revert To Original Setting
(SETVAR "CmdEcho" 1) ; Turn COMMAND Echo On
(PRINC) ; Soft Exit
)
;*** Function Takes Point And Converts It To An Isometric Point!
(DEFUN Calc_Point ( POINT / PX PY PZ DFBX DFBY DFXY)
(SETQ PX (nth 0 POINT) ; Get X Co-ord.
PY (nth 1 POINT) ; Get Y Co-ord.
PZ 0.0 ; Get Z Co-ord.
DFBX (- PX BPX) ; Calculate Distance From Base X
DFBY (- PY BPY) ; Calculate Distance From Base Y
DFXY (- DFBX DFBY); Calculate Difference From DFBX-DFBY
)
(COND
((= Iso_View "R") ; Right View Isometric
(PROGN
(SETQ PY (+ PY (* DFBX (SIN (DTR 30)))))
(SETQ PX (- PX (- DFBX (* DFBX (COS (DTR 30))))))
)
)
((= Iso_View "L") ; Left View Isometric
(PROGN
(SETQ PY (- PY (* DFBX (SIN (DTR 30)))))
(SETQ PX (- PX (- DFBX (* DFBX (COS (DTR 30))))))
)
)
((= Iso_View "TR") ; Top Right View Isometric
(PROGN
(SETQ PY (+ PY (* DFXY (SIN (DTR 30)))))
(SETQ PX (- (+ BPX (* DFBX (COS (DTR 30))))
(* DFBY (COS (DTR 30)))
)
)
)
)
)
(SETQ New_Point (LIST PX PY PZ))
)
;************************* MAIN LINE **************************
(DEFUN C:ISO ( / Blip SelSet NewSet New_Point Depth STxt
NL NC NA NS NT O BPX BPY Snap DepthAngle
)
(SetUp) ; SetUp Environment
(Setup_Layer) ; Ask Layer Information
(Get_Entities) ; Select An Entity Selection Set
(Which_View) ; Get Which View To Draw Iso
(Change_To_Iso) ; Change Entities To ISOMETRIC
(ShutDown) ; Set Vars. etc., to original values
(Display_Results) ; Tell User Results
)
(DEFUN C:DELISO ()
(SETQ SetUp nil
SetUp_Layer nil
Get_Entities nil
Which_View nil
Change_To_Iso nil
Arc_Extract_Draw nil
Line_Extract_Draw nil
Circle_Extract_Draw nil
Solid_Extract_Draw nil
Text_Extract_Draw nil
DTR nil
RTD nil
Display_Results nil
ShutDown nil
Calc_Point nil
C:ISO nil
)
)
(PRINC)
;END