PC World Komputer 1997 February

home *** CD-ROM | disk | FTP | other *** search

/ PC World Komputer 1997 February / PCWK0297.iso / autodesk / acltwin / dxfix13.dxt < prev next >

Wrap

Text File | 1996-05-30 | 87.4 KB | 2,648 lines

\ Notes, bugs and problems: \ 2. The anonymous blocks *MODEL_SPACE and *PAPER_SPACE in R13 are changed \ to the named blocks $MODEL_SPACE and $PAPER_SPACE in the R12 dxf file. \ 3. A RAY or XLINE without any entities will result in an exceedingly \ small line due to the small drawing extents. Putting a non-infinite \ entity in the drawing will remedy this problem. \ 4. *STACK 10000 - This doesn't seem to work since dictionary entries \ have already been made. \ 5. The stack notation: ( ... n n ) , used in the defining words below, \ assumes that the stack grows from left to right with the right most \ term being on top. \ 6. Make sure you have enough disk space for the output file, otherwise \ you will get no output. \ \ ======================================================================= \ README information 11/20/95: \ \ Fonts with Full Path Names. \ \ When font files are selected in R13 which are not on the Library \ path, the full path name is kept with the file, and is included \ in any DXF file created. This path is also kept after running \ the file through this translator. This can result in Release 12 \ attempting to use Release 13 font files, and then failing to \ load the DXF file. If this happens, removing the path from \ the filename in the DXF file will allow R12 to read the DXF file. \ For example, change: c:\r13\acad\support\txt.shx to txt.shx. \ Release 12 will then read in its own txt.shx file. \ \ OCTREE 6 Error: \ \ Some DXF files, created in Release 12, or created after using \ the DXF translator, result in this error while being read in. \ To "repair" the DXF file so that it can be read in, change the \ value of TREEDEPTH Group 70 to 3020. If desired, this value \ can then be reset to 0 from inside of AutoCAD, after the \ drawing has been read in. \ \ ======================================================================= \ \ Rules for translating AutoCAD Release 13 DXF files to Release 12 \ Command line options: -x => Delete RAYs and XLINEs, otherwise if this \ option is not present they will be replaced \ by finite lines that approximate the drawing \ extents. \ \ \ Changes made by this program to go from R13 to R12 DXF: \ 1. $ACADVER changed from AC1012 to AC1009 \ The following HEADER section variables were deleted: \ 2. $CELTSCALE \ 3. $DELOBJ \ 4. $DISPSILH \ 5. $DIMJUST \ 6. $DIMSD1 \ 7. $DIMSD2 \ 8. $DIMTOLJ \ 9. $DIMTZIN \ 10. $DIMALTZ \ 11. $DIMALTTZ \ 12. $DIMFIT \ 13. $DIMUPT \ 14. $DIMUNIT \ 15. $DIMDEC \ 16. $DIMTDEC \ 17. $DIMALTU \ 18. $DIMALTTD \ 19. $DIMTXSTY \ 20. $DIMAUNIT \ 21. $CHAMFERC \ 22. $CHAMFERD \ 23. $PICKSTYLE \ 24. $CMLSTYLE \ 25. $CMLJUST \ 26. $CMLSCALE \ 27. $SAVEIMAGES \ \ 28. CLASSES section deleted \ 29. OBJECTS section deleted \ 30. Delete 300-369 groups - arbitrary strings, chunks and handles \ 31. Delete 100 groups - AcDb... groups (eg. AcDbSymbolTable, AcDbLinetypeTableRecord, etc) \ \ The following ENTITIES section objects were changed: \ 32. RAY changed into a long, but finite, line. \ 33. ELLIPSE decomposed into polyline vertex segments. \ 34. BODY deleted. \ 35. OLEFRAME deleted. \ 36. 3DSOLID deleted. \ 37. DIMENSION removed -3 group. \ 38. INSERT removed -3 group. \ 39. VIEWPORT removed -3 group. \ 40. LEADER decomposed into polyline vertex segments. \ 41. MLINE deleted. \ 42. TOLERANCE deleted. \ 43. REGION deleted. \ 44. XLINE changed into a long, but finite, line. \ 45. MTEXT changed to TEXT. \ 46. SEQEND removed the -2 group. \ 47. SPLINE decomposed into polyline vertex segments. \ 48. ZOMBIE_ENTITY deleted. \ .( "Release 13 -> 12 DXF translator, Version 1.70 (08/18/95)\n" \ 'bignum' used to make RAYs and XLINEs long, finite lines. 1.0E99 2constant bignum 1.0E-3 2constant bignumerror 50 constant iterator 7 constant unicount 1.0 atan 4.0 f* 2constant pi 2.7182818 2constant e 180.0 pi f/ 2constant radToDeg pi 180.0 f/ 2constant degToRad 0 constant false -1 constant true 241 constant tolerSymbol \ DOS produces this one ... 248 constant degreeSymbol \ ... and Windows produces this one. 176 constant altDegreeSymbol 123 constant leftBrace 125 constant rightBrace 92 constant backSlash 94 constant separator 47 constant forwardSlash 59 constant semicolon 37 constant percent 32 constant space 48 constant ascii0 49 constant ascii1 50 constant ascii2 51 constant ascii3 52 constant ascii4 53 constant ascii5 54 constant ascii6 55 constant ascii7 56 constant ascii8 57 constant ascii9 100 constant littleD 108 constant littleL 111 constant littleO 117 constant littleU 65 constant bigA 67 constant bigC 70 constant bigF 72 constant bigH 76 constant bigL 79 constant bigO 80 constant bigP 81 constant bigQ 83 constant bigS 84 constant bigT 85 constant bigU 87 constant bigW -1 constant EOF 0 constant EOS 4 constant cell : cells cell * ; : cell+ cell + ; 2variable bignumhi 2variable bignumlo 2variable xmax 2variable ymax 2variable zmax variable maxset 2variable xmin 2variable ymin 2variable zmin variable minset variable handlesOn variable nextHandle variable needToRewind variable layer variable icount variable jcount variable loopCount variable maxi variable maxj 2variable ftmp variable delEndBlock \ MText variables variable fixedMtextGroups variable countChar variable thisChar variable nextChar variable group72 2variable textHeight 2variable textRotationPrimary 2variable textRotation variable color variable 62group 80 string mtextStyle variable 7group 5 string unicodeStr 5 string diameter 5 string toler 5 string degree 0.3 2constant mtextFudge \ R12 will not accept more than 256 characters in a DXF text entity. \ Oddly, you can 'saveasr12' in R13 with more than 256 characters in an \ MText entity and import the drawing into R12. However, doing a DXFOUT \ followed by DXFIN on that same drawing in R12 will result in an error. 256 constant mtextMaxLength file mtextFileA \ Ellipse variables 2variable ellipsea 2variable ellipseb 2variable ellipsestartangle 2variable ellipseendangle 2variable ellipseangleincr \ Spline variables 32 constant splineConstant variable splineIterator 2variable firstKnot 2variable knotInterval \ Number of segments used to approximate an ellipse. 128 constant ellipseSteps 1.0E-3 2constant ellipseanglefuzz \ Create a matrix of doubles : matrix create 2dup , , * 8 * allot ; \ Stack on entering: Stack on leaving: : element ( ... r c addr1 ) ( ... addr1+x ) dup >r ( ... r c addr1 ) @ ( ... r c columns ) rot ( ... c columns r ) * + ( ... columns*r+c ) \ Since the array consists of doubles, multiply by 8. 8 * \ Offset from the columns and rows stored at the head of this array. 8 + r> + ( ... addr1+x ) ; 1 3 matrix extentsMinSave 1 3 matrix extentsMaxSave 1 3 matrix vector 1 3 matrix result 1 3 matrix offset 1 3 matrix extrusion 3 3 matrix rotationMatrix \ Stack on entering: Stack on leaving: : 3x3print ( ... addr ) ( ... ) cr ." "Row Column Value" cr 0 icount ! begin 0 jcount ! icount @ 3 < while begin jcount @ 3 < while icount @ dup . ( ... addr icount ) jcount @ dup . ( ... addr icount jcount ) 2 pick ( ... addr icount jcount addr ) element 2@ f. cr ( ... addr ) 1 jcount +! repeat 1 icount +! repeat drop ( ... ) ; \ Stack on entering: Stack on leaving: : matrixprint ( ... row col addr ) ( ... ) cr ." "Row Column Value" cr swap ( ... row addr col ) maxj ! ( ... row addr ) swap ( ... addr row ) maxi ! ( ... addr ) 0 icount ! begin 0 jcount ! icount @ maxi @ < while begin jcount @ maxj @ < while icount @ dup . ( ... addr icount ) jcount @ dup . ( ... addr icount jcount ) 2 pick ( ... addr icount jcount addr ) element 2@ f. cr ( ... addr ) 1 jcount +! repeat 1 icount +! repeat drop ( ... ) ; \ Stack on entering: Stack on leaving: : matrixclear ( ... row col addr ) ( ... ) swap ( ... row addr col ) maxj ! ( ... row addr ) swap ( ... addr row ) maxi ! ( ... addr ) 0 icount ! begin 0 jcount ! icount @ maxi @ < while begin jcount @ maxj @ < while 0.0 ( ... addr 0.0 0.0 ) icount @ ( ... addr 0.0 0.0 icount ) jcount @ ( ... addr 0.0 0.0 icount jcount ) 4 pick ( ... addr 0.0 0.0 icount jcount addr ) element 2! ( ... addr ) 1 jcount +! repeat 1 icount +! repeat drop ( ... ) ; \ Stack on entering: Stack on leaving: : 1x33x3multiply ( ... addrv addrt ) ( ... ) 0 icount ! begin 0 jcount ! 0.0 ftmp 2! icount @ 3 < while begin jcount @ 3 < while jcount @ ( ... addrv addrt jcount ) icount @ ( ... addrv addrt jcount icount ) 2 pick ( ... addrv addrt jcount icount addrt ) \ Get the i,j element from the 3x3 matrix. element 2@ ( ... addrv addrt f1 f1 ) 0 jcount @ ( ... addrv addrt f1 f1 0 jcount ) 5 pick ( ... addrv addrt f1 f1 0 jcount addrv ) element 2@ ( ... addrv addrt f1 f1 f2 f2 ) f* ftmp 2@ f+ ( ... addrv addrt f3 f3 ) ftmp 2! ( ... addrv addrt ) 1 jcount +! repeat ftmp 2@ ( ... addrv addrt f4 f4 ) 0 icount @ ( ... addrv addrt f4 f4 0 icount ) result element 2! ( ... addrv addrt ) 1 icount +! repeat drop drop ( ... ) ; \ ************ START DEBUG-ONLY STUFF *************** \ Initialization routine : dxf:start \ -1 dumpinput ! \ Un-comment to dump input items \ -1 dumpoutput ! \ Un-comment to dump output items \ 6 outprec ! \ Un-comment to force ASCII output \ -1 mbchar ! \ Un-comment to force multibyte char interp \ dumpspecial false maxset ! false minset ! false handleson ! false needToRewind ! \ Only redo the translation if necessary. false delEndBlock ! \ true trace \ Un-comment for debugging. ; \ Manual translation program (equivalent to the standard loop, so it's \ commented out). \ : dxf:translate \ begin \ readitem while \ writeitem drop \ repeat \ ; \ Print point on stack 80 string edbuf 512 string longString : point. \ x y z -- 2rot "(%g," edbuf fstrform edbuf type 2swap "%g" edbuf fstrform edbuf type 2dup missing_z 2@ f= if ")" else ",%g)" edbuf fstrform edbuf then type ; \ ************* END DEBUG-ONLY STUFF ************** \ Defining words to make common translation operations easier \ and more expressive to specify. \ REMOVE DXF:bilge:rat -- Causes all instances of item RAT in section \ BILGE to be removed. (An explicit section \ name is expected; "*" is not valid here) : remove create does> drop 1 delitem ! ; \ DROP_Z DXF:header:$zilch -- The Z co-ordinate will be deleted from \ header variable ZILCH. : drop_z create does> drop 10 group 2drop missing_z 2@ 10 setgroup ; \ bitmask MASKFIELD DXF:*:*:<field> -- AND a field with a bitmask : maskfield create , \ Compile bitmask does> over \ Duplicate group index group \ Extract value of group swap \ Move bitmask address to the top @ \ Get value of bitmask and \ Mask the value of the field swap \ Get group code on top setgroup \ Update group in item \ stdout printitem ; \ DITCHGROUP DXF:*:<type>:<group> : ditchgroup create does> drop \ Get rid of word's address delgroup \ Delete this group from item ; \ ERRAT -- End an error message by editing the location in the \ file that the error occurred. : errat ." " at " itempos inbinary @ if "byte 0x%lX" else 1+ "line %ld" then edbuf strform edbuf type ." " of input file.\n" ; \ Stack on entering: Stack on leaving: : cmove ( ... from to n ) ( ... ) 0 do ( ... from to ) 2dup swap ( ... from to to from ) i + c@ ( ... from to to cfrom+i ) swap i + ( ... from to cfrom+i to+i ) c! ( ... from to ) loop drop drop ( ... ) ; \ Stack on entering: Stack on leaving: \ : strncmp ( ... str1 str2 n ) ( ... t/f ) \ \ Temporarily truncate the strings to n characters. \ dup ( ... str1 str2 n n ) \ 2 pick + dup ( ... str1 str2 n str2+n str2+n ) \ c@ ( ... str1 str2 n str2+n cstr2+n ) \ swap ( ... str1 str2 n cstr2+n str2+n ) \ 0 swap ( ... str1 str2 n cstr2+n 0 str2+n ) \ c! ( ... str1 str2 n cstr2+n ) \ swap dup ( ... str1 str2 cstr2+n n n ) \ 4 pick + dup ( ... str1 str2 cstr2+n n str1+n str1+n ) \ c@ ( ... str1 str2 cstr2+n n str1+n cstr1+n ) \ swap ( ... str1 str2 cstr2+n n cstr1+n str1+n ) \ 0 swap ( ... str1 str2 cstr2+n n cstr1+n 0 str1+n ) \ c! ( ... str1 str2 cstr2+n n cstr1+n ) \ swap ( ... str1 str2 cstr2+n cstr1+n n ) \ 4 pick ( ... str1 str2 cstr2+n cstr1+n n str1 ) \ 4 pick ( ... str1 str2 cstr2+n cstr1+n n str1 str2 ) \ strcmp ( ... str1 str2 cstr2+n cstr1+n n t/f ) \ \ \ Put the strings back the way they were. \ 3 roll ( ... str1 str2 cstr1+n n t/f cstr2+n ) \ 4 roll ( ... str1 cstr1+n n t/f cstr2+n str2 ) \ 3 pick + ( ... str1 cstr1+n n t/f cstr2+n str2+n ) \ c! ( ... str1 cstr1+n n t/f ) \ 2 roll ( ... str1 n t/f cstr1+n ) \ 3 roll ( ... n t/f cstr1+n str1 ) \ 3 roll + ( ... t/f cstr1+n str1+n ) \ c! ( ... t/f ) \ ; \ Equivalent to ROLL only used on doubles. \ The stack trace shown below uses 1 as an example. \ Doubles are represented as 2 words (eg. z1 z2). \ Stack on entering: Stack on leaving: : 2roll ( ... z1 z2 x1 x2 y1 y2 1 ) ( ... z1 z2 y1 y2 x1 x2 ) dup ( ... z1 z2 x1 x2 y1 y2 1 1 ) 1+ 2* ( ... z1 z2 x1 x2 y1 y2 1 4 ) roll ( ... z1 z2 x2 y1 y2 1 x1 ) swap ( ... z1 z2 x2 y1 y2 x1 1 ) 2* 1+ ( ... z1 z2 x2 y1 y2 x1 3 ) roll ( ... z1 z2 y1 y2 x1 x2 ) ; \ Stack on entering: Stack on leaving: : 2pick ( ... z1 z2 x1 x2 y1 y2 1 ) ( ... z1 z2 x1 x2 y1 y2 x1 x2 ) dup ( ... z1 z2 x1 x2 y1 y2 1 1 ) 1+ 2* ( ... z1 z2 x1 x2 y1 y2 1 4 ) pick ( ... z1 z2 x1 x2 y1 y2 1 x1 ) swap ( ... z1 z2 x1 x2 y1 y2 x1 1 ) 2* 1+ ( ... z1 z2 x1 x2 y1 y2 x1 3 ) pick ( ... z1 z2 x1 x2 y1 y2 x1 x2 ) ; \ Add 2 3Dpoints (composed of doubles). \ Stack on entering: Stack on leaving: : 2pointadd ( ... x1 y1 z1 x2 y2 z2 ) ( ... x3 y3 z3 ) 3 2roll ( ... x1 y1 x2 y2 z2 z1 ) f+ ( ... x1 y1 x2 y2 z3 ) 1 2roll ( ... x1 y1 x2 z3 y2 ) 3 2roll ( ... x1 x2 z3 y2 y1 ) f+ ( ... x1 x2 z3 y3 ) 3 2roll ( ... x2 z3 y3 x1 ) 3 2roll ( ... z3 y3 x1 x2 ) f+ ( ... z3 y3 x3 ) 1 2roll ( ... z2 x3 y3 ) 2 2roll ( ... x3 y3 z3 ) ; \ Multiply all components of a point (composed of doubles) by a double scalar. \ Stack on entering: Stack on leaving: : 2scalarMult ( ... x1 y1 z1 n ) ( ... x2 y2 z2 ) 2dup ( ... x1 y1 z1 n n ) 4 2roll ( ... y1 z1 n n x1 ) f* ( ... y1 z1 n x2 ) 2swap 2dup ( ... y1 z1 x2 n n ) 4 2roll ( ... z1 x2 n n y1 ) f* ( ... z1 x2 n y2 ) 2swap ( ... z1 x2 y2 n ) 3 2roll ( ... x2 y2 n z1 ) f* ( ... x2 y2 z2 ) ; \ Divide all components of a point (composed of doubles) by a double scalar. \ Stack on entering: Stack on leaving: : 2scalarDiv ( ... x1 y1 z1 n ) ( ... x2 y2 z2 ) 2dup ( ... x1 y1 z1 n n ) 4 2roll ( ... y1 z1 n n x1 ) 2swap ( ... y1 z1 n x1 n ) f/ ( ... y1 z1 n x2 ) 2swap 2dup ( ... y1 z1 x2 n n ) 4 2roll ( ... z1 x2 n n y1 ) 2swap ( ... z1 x2 n y1 n ) f/ ( ... z1 x2 n y2 ) 2swap ( ... z1 x2 y2 n ) 3 2roll ( ... x2 y2 n z1 ) 2swap ( ... x2 y2 z1 n ) f/ ( ... x2 y2 z2 ) ; \ Stack on entering: Stack on leaving: : 2pointprint ( ... x1 y1 z1 ) ( ... x1 y1 z1 ) 2 2roll 2dup ( ... y1 z1 x1 x1 ) ." "X=" f. ( ... y1 z1 x1 ) 2 2roll 2dup ( ... z1 x1 y1 y1 ) ." "Y=" f. ( ... z1 x1 y1 ) 2 2roll 2dup ( ... x1 y1 z1 z1 ) ." "Z=" f. cr ( ... x1 y1 z1 ) ; \ Is xmax >= x1 >= xmin? \ Stack on entering: Stack on leaving: : inside ( ... x1 xmax xmin ) ( ... t/f ) 2 2roll 2dup ( ... xmax xmin x1 x1 ) 3 2roll ( ... xmin x1 x1 xmax ) f<= if ( ... xmin x1 ) \ x1 is less than or equal to xmax f<= if ( ... ) \ xmin is less than or equal to x1 true ( ... true ) else false ( ... false ) then else ( ... xmin x1 ) 2drop 2drop false ( ... false ) then ; \ Stack on entering: Stack on leaving: : extentsok ( ... ) ( ... t/f ) maxset @ minset @ and if ( ... ) \ Extents are there. true ( ... true ) else \ Extents are missing. false ( ... false ) then ; \ Is the 3D point contained withing the drawing extents? \ Stack on entering: Stack on leaving: : insideextents ( ... x1 y1 z1 ) ( ... t/f ) extentsok not if ( ... x1 y1 z1 ) \ If the extents are missing or malformed then exit. 2drop 2drop 2drop true exit then zmax 2@ zmin 2@ ( ... x1 y1 z1 zmax zmin ) inside if ( ... x1 y1 ) ymax 2@ ymin 2@ ( ... x1 y1 ymax ymin ) inside if ( ... x1 ) xmax 2@ xmin 2@ ( ... x1 xmax xmin ) inside if ( ... ) true ( ... true ) else ( ... ) false ( ... false ) then else ( ... x1 ) 2drop false ( ... false ) then else ( ... x1 y1 ) 2drop 2drop false ( ... false ) then ; \ Initialize the high and low values for point * scalar multiplication \ Stack on entering: Stack on leaving: : initbignumrange ( ... ) ( ... ) bignum bignumhi 2! 1.0 bignum f/ bignumlo 2! ; \ Find a logarithmic mean between bignumhi and bignumlo \ Stack on entering: Stack on leaving: : bignummean ( ... ) ( ... f ) bignumhi 2@ log bignumlo 2@ log f+ 2.0 f/ e 2swap pow ; \ Stack on entering: Stack on leaving: : goodenough ( ... ) ( ... t/f ) bignumlo 2@ bignumhi 2@ f- fabs bignumerror f< ; ( Process command line options and set special operating modes ) : modeset "d" option if \ If -D option is set, turn on trace 1 dxftrace ! then ; \ End of defining words. Let the fun begin! modeset \ Process command line options ( Header variables to delete or modify ) : dxf:header:$acadver \ $ACADVER needs special processing "AC1009" 1 setgroup \ Substitute R12's version code ; \ : dxf:header:$dimscale \ $DIMSCALE needs special processing \ 40 group 0.0 f= if \ If it's zero (for paper space)... \ 1.0 40 setgroup \ ...substitute 1.0 \ then \ ; ( Symbol tables to delete or modify ) remove dxf:header:$celtscale remove dxf:header:$delobj remove dxf:header:$dispsilh remove dxf:header:$dimjust remove dxf:header:$dimsd1 remove dxf:header:$dimsd2 remove dxf:header:$dimtolj remove dxf:header:$dimtzin remove dxf:header:$dimaltz remove dxf:header:$dimalttz remove dxf:header:$dimfit remove dxf:header:$dimupt remove dxf:header:$dimunit remove dxf:header:$dimdec remove dxf:header:$dimtdec remove dxf:header:$dimaltu remove dxf:header:$dimalttd remove dxf:header:$dimtxsty remove dxf:header:$dimaunit remove dxf:header:$chamferc remove dxf:header:$chamferd remove dxf:header:$pickstyle remove dxf:header:$cmlstyle remove dxf:header:$cmljust remove dxf:header:$cmlscale remove dxf:header:$saveimages : dxf:header:$extmax true maxset ! 10 group zmax 2! ymax 2! xmax 2! ; \ Return the base-10 equivalent of a hexadecimal string. \ e.g. String "10" is converted to number 16. \ Stack on entering: Stack on leaving: : strhexint ( ... addr1 ) ( ... n ) "0x" edbuf strcpy ( ... addr1 ) edbuf ( ... addr1 edbuf ) strcat ( ... ) edbuf strint swap drop ( ... n ) ; : dxf:header:$handseed handleson @ if rewind @ if \ Second pass. 5 group strhexint ( ... oldnexthandle ) \ Handles are in hex. nexthandle @ "%lX" edbuf strform edbuf 5 setgroup \ Now load the 'nexthandle' with the original 'oldnexthandle'. nexthandle ! ( ... ) else \ First pass. 5 group strhexint nexthandle ! then else ." "Warning. Handle seed value present, but handles not enabled." then ; : dxf:header:$handling 70 group 0= if false handleson ! else true handleson ! then ; remove dxf:classes remove dxf:objects ( Entities to delete ) \ Since apps can now create their own entities, we don't know what \ entities should be deleted - only which ones to keep ... : removeUnknownEnts 0 group "SECTION" strcmp 0= if exit then 0 group "ENDSEC" strcmp 0= if exit then 0 group "3DFACE" strcmp 0= if exit then 0 group "ATTDEF" strcmp 0= if exit then 0 group "ATTRIB" strcmp 0= if exit then 0 group "ARC" strcmp 0= if exit then 0 group "CIRCLE" strcmp 0= if exit then 0 group "DIMENSION" strcmp 0= if exit then 0 group "INSERT" strcmp 0= if exit then 0 group "LINE" strcmp 0= if exit then 0 group "POINT" strcmp 0= if exit then 0 group "POLYLINE" strcmp 0= if exit then 0 group "SEQEND" strcmp 0= if exit then 0 group "SHAPE" strcmp 0= if exit then 0 group "SOLID" strcmp 0= if exit then 0 group "TEXT" strcmp 0= if exit then 0 group "TRACE" strcmp 0= if exit then 0 group "VERTEX" strcmp 0= if exit then 0 group "VIEWPORT" strcmp 0= if exit then 0 group "BLOCK" strcmp 0= if exit then 0 group "ENDBLK" strcmp 0= if exit then 1 delitem ! 1 specialdone ! ; ( Block definition transformations ) ( Dimension entity transformations ) ( Delete specific group data ) ditchgroup dxf:*:*:300-369 \ Drop all arbitrary strings, chunks and handles ditchgroup dxf:*:*:100 \ Drop all AcDb... groups (eg. AcDbSymbolTable, AcDbLinetypeTableRecord, etc) ditchgroup dxf:*:*:60 \ Ignor Invisibility flag ditchgroup dxf:*:VPORT:5 ditchgroup dxf:*:LTYPE:5 ditchgroup dxf:*:LTYPE:74-75 ditchgroup dxf:*:LTYPE:44-46 ditchgroup dxf:*:LTYPE:50 ditchgroup dxf:*:LAYER:5 ditchgroup dxf:*:STYLE:5 ditchgroup dxf:*:VIEW:5 ditchgroup dxf:*:UCS:5 ditchgroup dxf:*:APPID:5 ditchgroup dxf:*:APPID:71 ditchgroup dxf:*:MTEXT:1000-1100 : printobject ." "Object printout:" cr stdout printitem cr ; : dxf:tables:block_record 5 group? if 1 delitem ! then ; : removeXdata 1101 1000 do i dup loopCount ! ( ... i ) groupcount2 dup if ( ... count ) 0 do ( ... ) loopCount @ delgroup loop else ( ... count ) drop ( ... ) then loop ; \ Remove all XREF data from the TABLES section. : dxf:tables:vport removeXdata ; : dxf:tables:ltype removeXdata 9 delgroup 74 delgroup 2 group? if 2 group "BYBLOCK" strcmp 0= if 1 delitem ! then 2 group "BYLAYER" strcmp 0= if 1 delitem ! then then ; : dxf:tables:layer removeXdata ; : dxf:tables:style removeXdata ; : dxf:tables:view removeXdata ; : dxf:tables:ucs removeXdata ; : dxf:tables:appid removeXdata ; : dxf:tables:dimstyle groupcount 1 = if 0 group? if 1 delitem ! then then groupcount 4 = if 5 delgroup then 105 delgroup 100 delgroup 270 delgroup 271 delgroup 272 delgroup 273 delgroup 274 delgroup 275 delgroup 280 delgroup 281 delgroup 282 delgroup 283 delgroup 284 delgroup 285 delgroup 286 delgroup 287 delgroup 288 delgroup removeXdata ; : starmodel ( ... n ) dup dup ( ... n n n ) group? if ( ... n n ) group ( ... n addr1 ) "*MODEL_SPACE" ( ... n addr1 addr2 ) strcmp ( ... n flag ) 0= if ( ... n ) "$MODEL_SPACE" ( ... n addr3 ) swap ( ... addr3 n ) setgroup ( ... ) else ( ... n ) drop ( ... ) then else ( ... n n ) drop drop ( ... ) then ; \ Remove any existing "$MODEL_SPACE" blocks. These can occur in the following \ scenario: 1. DXFIX an R13 drawing. \ 2. Read in the R12 dxf file. \ 3. DXFOUT the new R13 drawing which now contains both $MODEL_SPACE \ and *MODEL_SPACE. \ 4. DXFIX this new R13 drawing and the old $MODEL_SPACE will be removed. : delmodel ( ... n ) dup ( ... n n ) group? if ( ... n ) group ( ... addr1 ) "$MODEL_SPACE" ( ... addr1 addr2 ) strcmp ( ... flag ) 0= if ( ... ) true delEndBlock ! clearitem writeitem drop then else ( ... n ) drop then ; : delpaper ( ... n ) dup ( ... n n ) group? if ( ... n ) group ( ... addr1 ) "$PAPER_SPACE" ( ... addr1 addr2 ) strcmp ( ... flag ) 0= if ( ... ) true delEndBlock ! clearitem writeitem drop then else ( ... n ) drop then ; : starpaper ( ... n ) dup dup ( ... n n n ) group? if ( ... n n ) group ( ... n addr1 ) "*PAPER_SPACE" ( ... n addr1 addr2 ) strcmp ( ... n flag ) 0= if ( ... n ) "$PAPER_SPACE" ( ... n addr3 ) swap ( ... addr3 n ) setgroup ( ... ) else ( ... n ) drop ( ... ) then else ( ... n n ) drop drop ( ... ) then ; : dxf:blocks:block 2 delmodel 3 delmodel 2 delpaper 3 delpaper 2 starmodel \ Change *MODEL_SPACE and *PAPER_SPACE 2 starpaper \ to $MODEL_SPACE and $PAPER_SPACE in 3 starpaper \ the 2 and 3 groups. 3 starmodel ; \ Note, don't want to delete the 48 group from the TABLES section. : dxf:blocks 0 group? if removeUnknownEnts 0 group ( ... addr1 ) "ENDBLK" ( ... addr1 addr2 ) strcmp ( ... flag ) 0= delEndBlock @ and if ( ... ) \ Delete the ENDBLK that corresponds to the PAPER/MODEL_SPACE \ block just deleted. false delEndBlock ! clearitem writeitem drop then then 48 delgroup ; : dxf:entities 0 group? if removeUnknownEnts then 48 delgroup ; : setHiLoRange insideextents if bignummean bignumlo 2! else bignummean bignumhi 2! then ; \ Add the offset from the origin. : addOffset 10 group 2pointadd ; \ Stack on entering: Stack on leaving: : setExtents ( ... ) ( ... ) xMin 2@ 0 0 extentsMinSave element 2! yMin 2@ 0 1 extentsMinSave element 2! zMin 2@ 0 2 extentsMinSave element 2! xMax 2@ 0 0 extentsMaxSave element 2! yMax 2@ 0 1 extentsMaxSave element 2! zMax 2@ 0 2 extentsMaxSave element 2! 10 group ( ... x y z ) \ Temporarily move the extents to include the origin of the RAY or XLINE. 2dup ( ... x y z z ) zMax 2@ ( ... x y z z zMax ) f> if ( ... x y z ) zMax 2! ( ... x y ) else ( ... x y z ) 2dup ( ... x y z z ) zMin 2@ ( ... x y z z zMin ) f< if ( ... x y z ) zMin 2! ( ... x y ) else ( ... x y z ) 2drop ( ... x y ) then then 2dup ( ... x y y ) yMax 2@ ( ... x y y yMax ) f> if ( ... x y ) yMax 2! ( ... x ) else ( ... x y ) 2dup ( ... x y y ) yMin 2@ ( ... x y y yMin ) f< if ( ... x y ) yMin 2! ( ... x ) else ( ... x y ) 2drop ( ... x ) then then 2dup ( ... x x ) xMax 2@ ( ... x x xMax ) f> if ( ... x ) xMax 2! ( ... ) else ( ... x ) 2dup ( ... x x ) xMin 2@ ( ... x x xMin ) f< if ( ... x ) xMin 2! ( ... ) else ( ... x ) 2drop ( ... ) then then ; \ Stack on entering: Stack on leaving: : resetExtents ( ... ) ( ... ) 0 0 extentsMinSave element 2@ xMin 2! 0 1 extentsMinSave element 2@ yMin 2! 0 2 extentsMinSave element 2@ zMin 2! 0 0 extentsMaxSave element 2@ xMax 2! 0 1 extentsMaxSave element 2@ yMax 2! 0 2 extentsMaxSave element 2@ zMax 2! ; : dxf:*:ray "x" option if 1 delitem ! else \ Bug in the interpreter makes multiple calls on one ray entity. \ The following code stops that. 0 group "LINE" strcmp 0= if exit then setExtents initbignumrange "LINE" 0 setgroup \ Turn a RAY into a line iterator 0 do 11 group \ Get the X,Y,Z components of the unit direction vector bignummean 2scalarmult addOffset setHiLoRange goodenough if leave then loop 11 group bignummean 2scalarmult addOffset 11 setgroup resetExtents then ; : dxf:*:xline "x" option if 1 delitem ! else setExtents initbignumrange "LINE" 0 setgroup \ Turn an XLINE into a line iterator 0 do 11 group \ Get the X,Y,Z components of the unit direction vector bignummean fnegate 2scalarmult addOffset setHiLoRange goodenough if leave then loop 11 group bignummean fnegate 2scalarmult addOffset \ Hold the results in the stack for later ... initbignumrange iterator 0 do 11 group \ Get the X,Y,Z components of the unit direction vector bignummean 2scalarmult addOffset setHiLoRange goodenough if leave then loop 11 group bignummean 2scalarmult addOffset 11 setgroup \ Set the end point \ ... OK, we can now set the 10 group 10 setgroup \ Set the start point resetExtents then ; \ Compute the length of a 3D vector which has one endpoint at 0,0,0. \ Stack on entering: Stack on leaving: : vectorLength ( ... x y z ) ( ... len ) 2.0 pow ( ... x y z**2 ) 2swap 2.0 pow ( ... x z**2 y**2 ) f+ ( ... x z**2+y**2 ) 2swap 2.0 pow ( ... z**2+y**2 x**2 ) f+ ( ... z**2+y**2+x**2 ) sqrt ( ... len ) ; \ angle = atan2(sin(p) * radiusRatio, cos(p)) \ Stack on entering: Stack on leaving: : ellipseparamtoangle ( ... p ) ( ... a ) 2dup ( ... p p ) sin ( ... p sin[p] ) 40 group f* ( ... p r*sin[p] ) 2swap ( ... r*sin[p] p ) cos ( ... r*sin[p] cos[p] ) atan2 ( ... a ) ; \ Stack on entering: Stack on leaving: : vector2dup ( ... x y z ) ( ... x y z x y z ) 2 2pick ( ... x y z x ) 2 2pick ( ... x y z x y ) 2 2pick ( ... x y z x y z ) ; \ Stack on entering: Stack on leaving: : vector2swap ( ... x1 y1 z1 x2 y2 z2 ) ( ... x2 y2 z2 x1 y1 z1 ) 5 2roll ( ... y1 z1 x2 y2 z2 x1 ) 5 2roll ( ... z1 x2 y2 z2 x1 y1 ) 5 2roll ( ... x2 y2 z2 x1 y1 z1 ) ; \ Dot product of u and v: u . v \ Stack on entering: Stack on leaving: : dotProduct ( ... x1 y1 z1 x2 y2 z2 ) ( ... x1x2+y1y2+z1z2 ) 2 2roll ( ... x1 y1 z1 y2 z2 x2 ) 5 2roll f* ( ... y1 z1 y2 z2 x2x1 ) 2 2roll ( ... y1 z1 z2 x2x1 y2 ) 4 2roll f* f+ ( ... z1 z2 x2x1+y2y1 ) 2swap ( ... z1 x2x1+y2y1 z2 ) 2 2roll f* f+ ( ... x2x1+y2y1+z2z1 ) ; \ Cross product of u and v: u x v \ Stack on entering: Stack on leaving: : crossProduct ( ... u1 u2 u3 v1 v2 v3 ) ( ... u2v3-u3v2 u3v1-u1v3 u1v2-u2v1 ) 4 2pick ( ... u1 u2 u3 v1 v2 v3 u2 ) 1 2pick f* ( ... u1 u2 u3 v1 v2 v3 u2v3 ) 4 2pick ( ... u1 u2 u3 v1 v2 v3 u2v3 u3 ) 3 2pick f* f- ( ... u1 u2 u3 v1 v2 v3 u2v3-u3v2 ) 4 2roll ( ... u1 u2 v1 v2 v3 u2v3-u3v2 u3 ) 4 2pick f* ( ... u1 u2 v1 v2 v3 u2v3-u3v2 u3v1 ) 6 2pick ( ... u1 u2 v1 v2 v3 u2v3-u3v2 u3v1 u1 ) 3 2roll f* f- ( ... u1 u2 v1 v2 u2v3-u3v2 u3v1-u1v3 ) 5 2roll ( ... u2 v1 v2 u2v3-u3v2 u3v1-u1v3 u1 ) 3 2roll f* ( ... u2 v1 u2v3-u3v2 u3v1-u1v3 u1v2 ) 4 2roll ( ... v1 u2v3-u3v2 u3v1-u1v3 u1v2 u2 ) 4 2roll f* f- ( ... u2v3-u3v2 u3v1-u1v3 u1v2-u2v1 ) ; \ Given a vector, scale its components to make it a unit vector. \ Stack on entering: Stack on leaving: : makeUnitVector ( ... x y z ) ( ... x1 y1 z1 ) vector2dup ( ... x y z x y z ) vectorLength ( ... x y z len ) 2scalarDiv ( ... x1 y1 z1 ) ; \ Angle between 2 vectors, where both vectors have one endpoint at 0,0,0 \ Use the dot product of these 2 vectors to calculate the angle between them. \ u.v = ||u|| ||v|| cos(theta) \ Stack on entering: Stack on leaving: : vectorangle ( ... ux uy uz vx vy vz ) ( ... theta ) vector2dup ( ... ux uy uz vx vy vz vx vy vz ) 8 2pick ( ... ux uy uz vx vy vz vx vy vz ux ) 8 2pick ( ... ux uy uz vx vy vz vx vy vz ux uy ) 8 2pick ( ... ux uy uz vx vy vz vx vy vz ux uy uz ) vector2swap ( ... ux uy uz vx vy vz ux uy uz vx vy vz ) dotProduct ( ... ux uy uz vx vy vz u.v ) 6 2roll ( ... uy uz vx vy vz u.v ux ) 6 2roll ( ... uz vx vy vz u.v ux uy ) 6 2roll ( ... vx vy vz u.v ux uy uz ) vectorLength ( ... vx vy vz u.v ulen ) 4 2roll ( ... vy vz u.v ulen vx ) 4 2roll ( ... vz u.v ulen vx vy ) 4 2roll ( ... u.v ulen vx vy vz ) vectorLength f* f/ ( ... u.v / ulen*vlen ) acos ( ... theta ) ; \ Is this 3D point 0,0,0 ? \ Stack on entering: Stack on leaving: : isZeroVector ( ... x y z ) ( ... x y z t/f ) 2dup ( ... x y z z ) 0.0 f= if ( ... x y z ) 1 2pick ( ... x y z y ) 0.0 f= if ( ... x y z ) 2 2pick ( ... x y z x ) 0.0 f= if ( ... x y z ) true ( ... x y z t ) else ( ... x y z ) false ( ... x y z f ) then else ( ... x y z ) false ( ... x y z f ) then else ( ... x y z ) false ( ... x y z f ) then ; : 2pi 2.0 pi f* ; \ Stack on entering: Stack on leaving: : normalizeEllipseAngle ( ... a1 ) ( ... a2 ) 2dup 0.0 f< if ( ... a1 ) \ If angle is less than 0 add 2pi radians to make it positive. 2pi f+ ( ... a2 ) then 2dup ( ... a1 a1 ) 2pi f>= if ( ... a1 ) \ If angle is greater than or equal to 2pi, subtract 2pi. 2pi f- then ; \ Stack on entering: Stack on leaving: : ellipseStepToPoint ( ... i ) ( ... x y z ) float ellipseangleincr 2@ f* ( ... angle ) ellipseStartAngle 2@ f+ normalizeEllipseAngle 2dup ( ... angle angle ) cos ellipsea 2@ f* ( ... angle x ) 2swap ( ... x angle ) sin ellipseb 2@ f* 0.0 ( ... x y 0.0 ) ; \ Stack on entering: Stack on leaving: : resulttovector ( ... ) ( ... ) 0 0 result element 2@ 0 0 vector element 2! 0 1 result element 2@ 0 1 vector element 2! 0 2 result element 2@ 0 2 vector element 2! ; \ Stack on entering: Stack on leaving: : ellipseApplyTransform ( ... x y z ) ( ... x y z ) 0 2 vector element 2! ( ... x y ) 0 1 vector element 2! ( ... x ) 0 0 vector element 2! ( ... ) vector rotationMatrix 1x33x3multiply \ Apply offset 0 0 result element 2@ ( ... x ) 0 1 result element 2@ ( ... x y ) 0 2 result element 2@ ( ... x y z ) 0 0 offset element 2@ ( ... x y z x ) 0 1 offset element 2@ ( ... x y z x y ) 0 2 offset element 2@ ( ... x y z x y z ) 2pointadd ( ... x2 y2 z2 ) ; \ Put a 16-bit short in file. \ Not to be confused with FPUTS which operates on a string, not a short. \ Stack on entering: Stack on leaving: : fputshort ( ... s file ) ( ... stat ) \ First byte over ( ... s file s ) over ( ... s file s file ) fputc drop ( ... s file ) \ Second byte swap ( ... file s ) \ Shift right -8 shift ( ... file s2 ) swap ( ... s2 file ) fputc ( ... stat ) ; \ Put a 32-bit word in file. \ Stack on entering: Stack on leaving: : fputw ( ... l file ) ( ... stat ) over ( ... l file l ) over ( ... l file l file ) fputshort drop ( ... l file ) swap ( ... file l ) \ Shift right -16 shift ( ... file l1 ) swap ( ... l1 file ) fputshort ( ... stat ) ; \ Put a 64-bit double word in file. \ Stack on entering: Stack on leaving: : fputd ( ... w2 w1 file ) ( ... stat ) rot ( ... w1 file w2 ) over ( ... w1 file w2 file ) fputw drop ( ... w1 file ) fputw ( ... stat ) ; \ Leave 'nexthandle' with the next valid handle to use. \ Stack on entering: Stack on leaving: : addHandle ( ... ) ( ... ) handleson @ if \ Handles are in hex. nexthandle @ "%lX" edbuf strform inbinary @ if 5 ofile fputc drop edbuf strlen 1+ edbuf ofile fwrite drop else " 5" ofile fputs drop edbuf ofile fputs drop then 1 nexthandle +! true needToRewind ! then ; \ Stack on entering: Stack on leaving: : saveLayer ( ... ) ( ... ) 8 group? if ( ... ) 8 group ( ... addr ) strint swap drop ( ... n ) else ( ... ) 0 ( ... 0 ) then layer ! ( ... ) ; \ Stack on entering: Stack on leaving: : saveColor 62 group? if 62 group color ! true else false then 62group ! ; \ Stack on entering: Stack on leaving: : addLayer ( ... ) ( ... ) layer @ "%ld" edbuf strform inbinary @ if 8 ofile fputc drop edbuf strlen 1+ edbuf ofile fwrite drop else " 8" ofile fputs drop edbuf ofile fputs drop then ; \ Stack on entering: Stack on leaving: : addVertexHeader ( ... ) ( ... ) \ Add a new vertex. "VERTEX" edbuf strcpy inbinary @ if 0 ofile fputc drop edbuf strlen 1+ edbuf ofile fwrite drop else " 0" ofile fputs drop edbuf ofile fputs drop then addLayer addHandle ; \ Stack on entering: Stack on leaving: : addVertexTrailer ( ... ) ( ... ) inbinary @ if 70 ofile fputc drop 32 ofile fputshort drop else " 70" ofile fputs drop " 32" ofile fputs drop then ; \ Stack on entering: Stack on leaving: : addSequend ( ... ) ( ... ) "SEQEND" edbuf strcpy inbinary @ if 0 ofile fputc drop edbuf strlen 1+ edbuf ofile fwrite drop else " 0" ofile fputs drop edbuf ofile fputs drop then addLayer addHandle ; \ Stack on entering: Stack on leaving: : add10Group ( ... x y z ) ( ... ) inbinary @ if 10 ofile fputc drop 2 2roll ( ... y z x ) ofile fputd drop ( ... y z ) 20 ofile fputc drop 2swap ( ... z y ) ofile fputd drop ( ... z ) 30 ofile fputc drop ofile fputd drop ( ... ) else " 10" ofile fputs drop 2 2roll ( ... y z x ) "%#g" edbuf fstrform ( ... y z ) edbuf ofile fputs drop " 20" ofile fputs drop 2swap ( ... z y ) "%#g" edbuf fstrform ( ... z ) edbuf ofile fputs drop " 30" ofile fputs drop "%#g" edbuf fstrform ( ... ) edbuf ofile fputs drop then ; : dxf:header:$extmin true minset ! 10 group ( ... x y z ) zmin 2! ymin 2! xmin 2! ; \ Stack on entering: Stack on leaving: : addColor 62group @ if inbinary @ if 62 ofile fputc drop color @ ofile fputshort drop else " 62" ofile fputs drop color @ "%ld" edbuf strform edbuf ofile fputs drop then then ; \ Stack on entering: Stack on leaving: : addPolylineHeader ( ... ) ( ... ) "POLYLINE" edbuf strcpy inbinary @ if 0 ofile fputc drop edbuf strlen 1+ edbuf ofile fwrite drop else " 0" ofile fputs drop edbuf ofile fputs drop then addLayer addHandle addColor inbinary @ if 66 ofile fputc drop 1 ofile fputshort drop else " 66" ofile fputs drop " 1" ofile fputs drop then add10Group ; : add3dPolylineHeader ( ... ) ( ... ) inbinary @ if 70 ofile fputc drop 8 ofile fputshort drop else " 70" ofile fputs drop " 8" ofile fputs drop then ; : addVertex addVertexHeader add10Group ; \ Stack on entering: Stack on leaving: : saveOffset ( ... ) ( ... ) 10 group ( ... x y z ) 0 2 offset element 2! 0 1 offset element 2! 0 0 offset element 2! ; : dxf:*:ellipse saveLayer saveOffset removeXdata 11 group ( ... x y z ) \ Calculate the parameter 'a' for the ellipse equation: x = a cos(theta), y = b sin(theta) vectorLength 2dup ellipsea 2! ( ... len ) \ Calculate the parameter 'b'. 40 group ( ... len p ) f* ellipseb 2! ( ... ) \ Calculate the start angle. 41 group ( ... a1 ) ellipseparamtoangle ( ... a2 ) normalizeEllipseAngle ellipseStartAngle 2! ( ... ) \ Calculate the end angle. 42 group ( ... a1 ) ellipseparamtoangle ( ... a2 ) normalizeEllipseAngle ellipseEndAngle 2dup 2! ( ... endangle ) ellipseStartAngle 2@ ( ... endangle startangle ) f- fabs ( ... deltaangle ) ellipseanglefuzz f> if \ An elliptical arc. ellipseStartAngle 2@ ( ... s ) ellipseEndAngle 2@ ( ... s e ) f> if \ Start angle greater than end angle. 2pi ellipseStartAngle 2@ f- ellipseEndAngle 2@ f+ else ellipseEndAngle 2@ ( ... e ) ellipseStartAngle 2@ ( ... s ) f- ( ... arcangle ) then else \ A full ellipse, not an elliptical arc. 2pi ( ... 2pi ) then ellipseSteps float f/ ellipseangleincr 2! \ Set up the rotation matrix. 210 group ( ... x3 y3 z3 ) vector2dup ( ... x3 y3 z3 x3 y3 z3 ) 2 2 rotationMatrix element 2! ( ... x3 y3 z3 x3 y3 ) 2 1 rotationMatrix element 2! ( ... x3 y3 z3 x3 ) 2 0 rotationMatrix element 2! ( ... x3 y3 z3 ) 11 group ( ... x3 y3 z3 x y z ) makeUnitVector ( ... x3 y3 z3 x1 y1 z1 ) vector2dup ( ... x3 y3 z3 x1 y1 z1 x1 y1 z1 ) 0 2 rotationMatrix element 2! ( ... x3 y3 z3 x1 y1 z1 x1 y1 ) 0 1 rotationMatrix element 2! ( ... x3 y3 z3 x1 y1 z1 x1 ) 0 0 rotationMatrix element 2! ( ... x3 y3 z3 x1 y1 z1 ) crossProduct ( ... x4 y4 z4 ) 1 2 rotationMatrix element 2! ( ... x4 y4 ) 1 1 rotationMatrix element 2! ( ... x4 ) 1 0 rotationMatrix element 2! ( ... ) "POLYLINE" 0 setgroup \ Turn an ELLIPSE into a POLYLINE \ Need to set point from the 0th VERTEX here. 11 delgroup 40 delgroup 41 delgroup 42 delgroup 48 delgroup 66 group? not if 66 addgroup then 1 66 setgroup 70 group? not if 70 addgroup then 8 70 setgroup 210 delgroup 0 ellipseStepToPoint ( ... x y z ) ellipseApplyTransform 10 setgroup ( ... ) \ Need to force a write of this item in order to append explicit VERTEX items. writeitem drop \ Calculate points on the ellipse. ellipseSteps 1+ 0 do i ellipseStepToPoint ( ... x y z ) ellipseApplyTransform \ 2pointprint addVertex loop addSequend ; : dxf:entities:dimension \ -3 delgroup 3 delgroup ; \ : dxf:entities:insert \ -3 delgroup \ ; \ : dxf:entities:viewport \ -3 delgroup \ ; : dxf:entities:seqend -2 delgroup ; : addRotationAngle ( ... ) ( ... ) textRotation 2@ 0.0 f= not if inbinary @ if 50 ofile fputc drop else " 50" ofile fputs drop ( ... x y z ) then textRotation 2@ inbinary @ if ofile fputd drop else "%#g" edbuf fstrform edbuf ofile fputs drop then then ; \ Stack on entering: Stack on leaving: : getArbitraryXAxis ( ... x y z ) ( ... x3 y3 z3 ) \ See pg. 272 of the AutoCAD R12 Customization Manual. 2 2pick ( ... x y z x ) \ 0.015625 = 1/64 0.015625 f< if ( ... x y z ) 1 2pick ( ... x y z y ) 0.015625 f< if ( ... x y z ) 0.0 1.0 0.0 ( ... x y z 0.0 1.0 0.0 ) else ( ... x y z ) 0.0 0.0 1.0 ( ... x y z 0.0 0.0 1.0 ) then else ( ... x y z ) 0.0 0.0 1.0 ( ... x y z 0.0 0.0 1.0 ) then vector2swap ( ... 0.0 0.0 1.0 x y z ) crossProduct ( ... x2 y2 z2 ) makeUnitVector ( ... x3 y3 z3 ) ; \ Stack on entering: Stack on leaving: : saveExtrusion ( ... ) ( ... ) 0.0 2dup ( ... ang ang ) textRotation 2! ( ... ang ) textRotationPrimary 2! ( ... ) 210 group? if 210 group ( ... Zx Zy Zz ) vector2dup ( ... Zx Zy Zz Zx Zy Zz ) \ Set up the rotation matrix Z 2 2 rotationMatrix element 2! 1 2 rotationMatrix element 2! 0 2 rotationMatrix element 2! ( ... Zx Zy Zz ) vector2dup ( ... Zx Zy Zz Zx Zy Zz ) getArbitraryXAxis ( ... Zx Zy Zz Xx Xy Xz ) vector2dup ( ... Zx Zy Zz Xx Xy Xz Xx Xy Xz ) \ Set up the rotation matrix X 2 0 rotationMatrix element 2! 1 0 rotationMatrix element 2! 0 0 rotationMatrix element 2! ( ... Zx Zy Zz Xx Xy Xz ) vector2dup ( ... Zx Zy Zz Xx Xy Xz Xx Xy Xz ) 8 2pick ( ... Zx Zy Zz Xx Xy Xz Xx Xy Xz Zx ) 8 2pick ( ... Zx Zy Zz Xx Xy Xz Xx Xy Xz Zx Zy ) 8 2pick ( ... Zx Zy Zz Xx Xy Xz Xx Xy Xz Zx Zy Zz ) vector2swap ( ... Zx Zy Zz Xx Xy Xz Zx Zy Zz Xx Xy Xz ) crossProduct ( ... Zx Zy Zz Xx Xy Xz Yx Yy Yz ) makeUnitVector \ Set up the rotation matrix Y 2 1 rotationMatrix element 2! 1 1 rotationMatrix element 2! 0 1 rotationMatrix element 2! ( ... Zx Zy Zz Xx Xy Xz ) \ Now transform the offset from World Coordinate System to Local CS. offset rotationMatrix 1x33x3multiply 0 0 result element 2@ ( ... Zx Zy Zz Xx Xy Xz Xlcs ) 0 1 result element 2@ ( ... Zx Zy Zz Xx Xy Xz Xlcs Ylcs ) 0 2 result element 2@ ( ... Zx Zy Zz Xx Xy Xz Xlcs Ylcs Zlcs ) 0 2 offset element 2! 0 1 offset element 2! 0 0 offset element 2! ( ... Zx Zy Zz Xx Xy Xz ) 2drop 2swap ( ... Zx Zy Zz Xy Xx ) atan2 ( ... Zx Zy Zz rad ) 2.0 pi f* 2swap f- ( ... Zx Zy Zz 2pi-rad ) radToDeg f* ( ... Zx Zy Zz arbAxisAng ) \ Get angle between WCS X-axis and LCS X-axis 11 group? if ( ... Zx Zy Zz arbAxisAng ) 11 group ( ... Zx Zy Zz arbAxisAng x y z ) 0 2 vector element 2! 0 1 vector element 2! 0 0 vector element 2! vector rotationMatrix 1x33x3multiply 0 1 result element 2@ ( ... Zx Zy Zz arbAxisAng y ) 0 0 result element 2@ ( ... Zx Zy Zz arbAxisAng y x ) atan2 radToDeg f* ( ... Zx Zy Zz arbAxisAng LCSang ) 1.0 0.0 0.0 ( ... Zx Zy Zz arbAxisAng LCSang 1.0 0.0 0.0 ) 2 0 rotationMatrix element 2@ 1 0 rotationMatrix element 2@ 0 0 rotationMatrix element 2@ ( ... Zx Zy Zz arbAxisAng LCSang 1.0 0.0 0.0 x y z ) vectorangle radToDeg f* ( ... Zx Zy Zz arbAxisAng LCSang theta ) f+ ( ... Zx Zy Zz arbAxisAng rotationAng ) 2dup ( ... Zx Zy Zz arbAxisAng rotationAng rotationAng ) textRotationPrimary 2! ( ... Zx Zy Zz arbAxisAng roationAng ) f+ ( ... Zx Zy Zz arbAxisAng2 ) textRotation 2! ( ... Zx Zy Zz ) then else \ Indicates no 210 group was present. 0.0 0.0 0.0 then 0 2 extrusion element 2! 0 1 extrusion element 2! 0 0 extrusion element 2! ; \ Stack on entering: Stack on leaving: : save72Group ( ... ) ( ... ) 72 group? if 72 group group72 ! else ." "Warning. No 72 group in MText entity." cr then ; \ Stack on entering: Stack on leaving: : saveHeight ( ... ) ( ... ) 40 group textHeight 2! ; \ Stack on entering: Stack on leaving: : addExtrusion ( ... ) ( ... ) 0 2 extrusion element 2@ ( ... z ) 0 1 extrusion element 2@ ( ... z y ) 0 0 extrusion element 2@ ( ... z y x ) isZeroVector not if inbinary @ if 210 ofile fputc drop ofile fputd drop ( ... z y ) 220 ofile fputc drop ofile fputd drop ( ... z ) 230 ofile fputc drop ofile fputd drop ( ... ) else "210" ofile fputs drop "%#g" edbuf fstrform ( ... z y ) edbuf ofile fputs drop "220" ofile fputs drop "%#g" edbuf fstrform ( ... z ) edbuf ofile fputs drop "230" ofile fputs drop "%#g" edbuf fstrform ( ... ) edbuf ofile fputs drop then else 2drop 2drop 2drop then ; \ Stack on entering: Stack on leaving: : add72Group ( ... ) ( ... ) \ Transform 72 into 71 group. inbinary @ if 72 ofile fputc drop 0 ofile fputshort drop else " 72" ofile fputs drop "0" ofile fputs drop then group72 @ dup ( ... n n ) 1 = if ( ... n ) drop ( ... ) inbinary @ if 71 ofile fputc drop 0 ofile fputshort drop else " 71" ofile fputs drop "0" ofile fputs drop then else 3 = if inbinary @ if 71 ofile fputc drop 0 ofile fputshort drop else " 71" ofile fputs drop "0" ofile fputs drop then then then ; \ Stack on entering: Stack on leaving: : addTextHeader ( ... ) ( ... ) \ Add a new TEXT entity. "TEXT" edbuf strcpy inbinary @ if 0 ofile fputc drop edbuf strlen 1+ edbuf ofile fwrite drop addLayer 40 ofile fputc drop textHeight 2@ ofile fputd drop else " 0" ofile fputs drop edbuf ofile fputs drop addLayer " 40" ofile fputs drop textHeight 2@ ( ... addr ) "%g" edbuf fstrform ( ... ) edbuf ofile fputs drop then addHandle addColor addRotationAngle add72group addExtrusion ; \ Stack on entering: Stack on leaving: : addTextStyle 7group @ if inbinary @ if 7 ofile fputc drop mtextStyle strlen 1+ mtextStyle ofile fwrite drop else " 7" ofile fputs drop mtextStyle ofile fputs drop then then ; \ Stack on entering: Stack on leaving: : addTextPosition ( ... ) ( ... ) 0 0 offset element 2@ ( ... x ) 0 1 offset element 2@ ( ... x y ) 0 2 offset element 2@ ( ... x y z ) add10Group ; \ Stack on entering: Stack on leaving: : setNewTextPosition ( ... ) ( ... ) 0 2 extrusion element 2@ ( ... z ) 0 1 extrusion element 2@ ( ... z y ) 0 0 extrusion element 2@ ( ... z y x ) isZeroVector if textHeight 2@ 2dup ( ... height height ) mtextFudge f* f+ 2dup ( ... newheight newheight ) \ X component textRotationPrimary 2@ sin f* ( ... newheight sin*newheight ) 0 0 offset element 2@ f+ 0 0 offset element 2! ( ... newheight ) \ Y component textRotationPrimary 2@ cos f* ( ... cos*newheight ) 0 1 offset element 2@ 2swap f- 0 1 offset element 2! ( ... ) else textHeight 2@ 2dup ( ... height height ) mtextFudge f* f+ 2dup ( ... newheight newheight ) \ X component textRotationPrimary 2@ degToRad f* sin f* ( ... newheight sin*newheight ) 0 0 vector element 2! ( ... newheight ) \ Y component textRotationPrimary 2@ degToRad f* cos f* -1.0 f* ( ... cos*newheight ) 0 1 vector element 2! ( ... ) 0.0 0 2 vector element 2! \ Transform this offset into the new coordinate system vector rotationMatrix 1x33x3multiply 0 0 result element 2@ ( ... x ) 0 1 result element 2@ ( ... x y ) 0 2 result element 2@ ( ... x y z ) \ ." "vector after" cr \ 2pointprint 0 0 offset element 2@ ( ... x y z x1 ) 0 1 offset element 2@ ( ... x y z x1 y1 ) 0 2 offset element 2@ ( ... x y z x1 y1 z1 ) 2pointadd ( ... x2 y2 z2 ) 0 2 offset element 2! 0 1 offset element 2! 0 0 offset element 2! then 2drop 2drop 2drop ; \ Stack on entering: Stack on leaving: : mtextReadChar ( ... ) ( ... ) mtextFileA ftell ( ... p ) dup 0 mtextFileA fseek ( ... p ) mtextFileA fgetc ( ... p c1 ) dup ( ... p c1 c1 ) EOF = if ( ... p c1 ) dup ( ... p c1 c1 ) thisChar ! ( ... p c1 ) nextChar ! ( ... p ) drop else ( ... p c1 ) thisChar ! ( ... p ) 1+ dup 0 mtextFileA fseek ( ... p2 ) mtextFileA fgetc ( ... p2 c2 ) nextChar ! ( ... p2 ) 0 mtextFileA fseek ( ... ) then ; \ Stack on entering: Stack on leaving: : mtextWriteChar ( ... ) ( ... ) thisChar @ ( ... c ) longString countChar @ + c! 1 countChar +! ; \ Stack on entering: Stack on leaving: : addLongString ( ... ) ( ... ) \ Save the character ... thisChar @ ( ... c ) EOS thisChar ! mtextWriteChar \ ... now restore it. thisChar ! inbinary @ if 1 ofile fputc drop longString strlen 1+ longString ofile fwrite drop else " 1" ofile fputs drop longString ofile fputs drop then 0 countChar ! ; \ Stack on entering: Stack on leaving: : equalToThisChar ( ... c1 ) ( ... ) thisChar @ = ( ... t/f ) ; \ Stack on entering: Stack on leaving: : equalToNextChar ( ... c1 ) ( ... ) nextChar @ = ( ... t/f ) ; \ Stack on entering: Stack on leaving: : deleteSemicolon iterator 0 do mtextReadChar semicolon equalToThisChar if leave then loop ; : mtextActionUnicode "2205" diameter strcpy "00B1" toler strcpy "00B0" degree strcpy diameter unicodeStr strcmp 0= if percent thisChar ! mtextWriteChar percent thisChar ! mtextWriteChar "c" thisChar strcpy mtextWriteChar else toler unicodeStr strcmp 0= if percent thisChar ! mtextWriteChar percent thisChar ! mtextWriteChar "p" thisChar strcpy mtextWriteChar else degree unicodeStr strcmp 0= if percent thisChar ! mtextWriteChar mtextWriteChar "d" thisChar strcpy mtextWriteChar else "?" thisChar strcpy mtextWriteChar then then then ; \ A backslash has already been encountered. The next character dictates the action. \ Stack on entering: Stack on leaving: : mtextActionBackslash ( ... ) ( ... n ) \ '\' backSlash equalToNextChar if mtextReadChar mtextWriteChar exit then \ '{' leftBrace equalToNextChar if mtextReadChar mtextWriteChar exit then \ '}' rightBrace equalToNextChar if mtextReadChar mtextWriteChar exit then \ 'O' bigO equalToNextChar if mtextReadChar percent thisChar ! mtextWriteChar mtextWriteChar bigO thisChar ! mtextWriteChar exit then \ 'C' bigC equalToNextChar if deleteSemicolon exit then \ 'F' bigF equalToNextChar if deleteSemicolon exit then \ 'H' bigH equalToNextChar if deleteSemicolon exit then \ 'A' bigA equalToNextChar if mtextReadChar mtextReadChar thisChar @ ascii0 - dup ( ... n n ) \ Valid realignment values: 0 1 2 0 = if ( ... n ) drop ( ... ) \ Offset = (1 1/3)*Height textHeight 2@ ( ... height ) 1.33 f* 2dup ( ... 1.33height 1.33height ) \ Y-value 0 1 offset element 2@ ( ... 1.33height 1.33height y ) 2swap f- ( ... 1.33height y-1.33height 0 1 offset element 2! ( ... 1.33height ) \ X-value 0 0 offset element 2@ ( ... 1.33height x ) 2swap f- ( ... x-1.33height 0 0 offset element 2! ( ... ) else ( ... n ) 1 = if ( ... ) \ Offset = (2/3)*Height textHeight 2@ ( ... height ) 0.47 f* ( ... Cheight ) \ Y-value 0 1 offset element 2@ ( ... Cheight y ) 2swap f- ( ... y-Cheight ) 0 1 offset element 2! ( ... ) \ X-value textHeight 2@ ( ... height ) 2.0 f* ( ... Cheight ) 0 0 offset element 2@ ( ... Cheight x ) 2swap f- ( ... x-Cheight ) 0 0 offset element 2! ( ... ) then then \ Delete the semicolon. mtextReadChar exit then \ 'U' bigU equalToNextChar if 2 0 do mtextReadChar loop 4 0 do mtextReadChar thisChar @ unicodeStr i + c! loop mtextActionUnicode exit then \ 'S' bigS equalToNextChar if mtextReadChar space thisChar ! mtextWriteChar iterator 0 do mtextReadChar separator equalToThisChar if forwardSlash thisChar ! then mtextWriteChar semicolon equalToNextChar if mtextReadChar leave then loop exit then \ 'o' littleO equalToNextChar if mtextReadChar percent thisChar ! mtextWriteChar mtextWriteChar littleO thisChar ! mtextWriteChar exit then \ 'L' bigL equalToNextChar if mtextReadChar percent thisChar ! mtextWriteChar mtextWriteChar bigU thisChar ! mtextWriteChar exit then \ 'l' littleL equalToNextChar if mtextReadChar percent thisChar ! mtextWriteChar mtextWriteChar littleU thisChar ! mtextWriteChar exit then \ 'P' bigP equalToNextChar if mtextReadChar addTextHeader addTextPosition setNewTextPosition addLongString addTextStyle exit then \ 'Q' bigQ equalToNextChar if deleteSemicolon exit then \ The default action. mtextWriteChar ; \ Stack on entering: Stack on leaving: : mtextAction ( ... ) ( ... n ) \ '{' leftBrace equalToThisChar if \ No action exit then \ '}' rightBrace equalToThisChar if \ No action exit then \ '\' backSlash equalToThisChar if \ Need to check the next character. mtextActionBackslash exit then \ o degreeSymbol equalToThisChar if percent thisChar ! mtextWriteChar mtextWriteChar littleD thisChar ! mtextWriteChar exit else altDegreeSymbol equalToThisChar if percent thisChar ! mtextWriteChar mtextWriteChar littleD thisChar ! mtextWriteChar exit then then \ plus/minus symbol tolerSymbol equalToThisChar if percent thisChar ! mtextWriteChar mtextWriteChar "p" thisChar strcpy mtextWriteChar exit then \ percent percent equalToThisChar if percent thisChar ! mtextWriteChar mtextWriteChar mtextWriteChar exit then \ The default action. mtextWriteChar ; : dxf:*:mtext "$mtexta.$ac" 11 mtextFileA fopen if saveHeight saveOffset saveLayer saveColor save72group saveExtrusion 0 3 group? if drop 3 groupcount2 then 1 group? if 1+ then dup groupcount swap - 11 group? if 1- then 210 group? if 1- then 7 group? if 1- 7 group mtextStyle strcpy true else false then 7group ! fixedMtextGroups ! \ Top stack item 'p' contains the number of text groups which could \ be multiple 3 and one 1 group, or just multiple 3 groups. \ dup ( ... p p ) \ ." "Number of 3 and/or 1 groups in this entity = " . cr ( ... p ) 0 do ( ... ) i fixedMtextGroups @ + ( ... n ) -10000 swap - ( ... -10000-n ) dup ( ... -10000-n -10000-n ) group strlen ( ... -10000-n m ) swap ( ... m -10000-n ) group ( ... m addr ) mtextFileA ( ... m addr file ) fwrite drop ( ... ) loop \ OK, all text is now written to 'mtextFileA'. \ Now delete everything. clearitem writeitem drop \ Now start reading the text from the temporary file taking the \ appropriate actions on control characters. \ Rewind the file. 0 0 mtextFileA fseek 0 countChar ! setNewTextPosition mtextReadChar begin EOF equalToThisChar not while mtextAction mtextReadChar countChar @ mtextMaxLength >= if addTextHeader addTextPosition setNewTextPosition addLongString addTextStyle then repeat \ Flush out the last Text entity. countChar @ if addTextHeader addTextPosition addLongString addTextStyle then mtextFileA fclose "$mtexta.$ac" fdelete drop else ." "Cannot open MText temporary file.\n" then ; \ Stack on entering: Stack on leaving: : getSplineItem ( ... #k p ) ( ... #k p K ) dup ( ... #k p p ) -10000 ( ... #k p p -10000 ) swap - ( ... #k p -10000-p ) 2 pick - 1+ ( ... #k p -10000-p-#k+1 ) ; : dxf:*:spline saveLayer saveColor \ The spline iterator is proportional to the number of control points. 73 group ( ... n ) splineConstant * ( ... m ) splineIterator ! ( ... ) \ Knots 72 group dup ( ... #k #k ) 40 itempos2 ( ... #k #k p ) \ Store value of first knot value. dup ( ... #k #k p p ) -10000 swap - ( ... #k #k p -10000-p ) group ( ... #k #k p K0 ) firstKnot 2! ( ... #k #k p ) 2dup ( ... #k #k p #k p ) -10000 swap - ( ... #k #k p #k -10000-p ) swap - 1+ ( ... #k #k p -10000-p-#k+1 ) \ Make sure we're within the domain range. group 1.0E-11 f- ( ... #k #k p Kn ) firstKnot 2@ f- fabs ( ... #k #k p abs[Kn-K0] ) splineIterator @ 1 - float f/ knotInterval 2! ( ... #k #k p ) swap ( ... #k p #k ) 0 do ( ... #k p ) getSplineItem i + ( ... #k p -10000-p-#k+1+i ) group ( ... #k p K ) 2swap ( ... K #k p ) loop drop ( ... Kn...K0 #k ) \ Control points 73 group dup ( .... #c #c ) 10 itempos2 ( .... #c #c p ) swap ( .... #c p #c ) 41 group? if \ Group sequence: 10-20-30-41-10-20-30-41 ... \ Position: -10000 - (p+2(#c-i-1)) 0 do ( .... #c p ) dup ( .... #c p p ) 2 pick ( .... #c p p #c ) i - 1- ( .... #c p p #c-i-1 ) 2* ( .... #c p p 2[#c-i-1] ) + ( .... #c p p+2[#c-i-1] ) -10000 swap - ( .... #c p -10000-[p+2[#c-i-1] ) group ( .... #c p Cx Cy Cz ) 3 2roll ( .... Cx Cy Cz #c p ) loop else \ Group sequence: 10-20-30-10-20-30... \ Position: -10000-p-#c+1+i 0 do ( .... #c p ) getSplineItem i + ( .... #c p -10000-p-#c+1+i ) group ( .... #c p Cx Cy Cz ) 3 2roll ( .... Cx Cy Cz #c p ) loop then drop ( ... Kn...K0 #k CxmCymCzm...Cx0Cy0Cz0 #c ) \ Weights 41 group? not if \ Same number of weights as control points. dup ( .... #c #c ) 0 do ( .... #c ) dup ( .... #c #c ) 1.0 ( .... #c #c 1.0 ) 2swap ( .... 1.0 #c #c ) drop ( .... 1.0 #c ) loop else \ Same number of weights as control points. dup ( .... #c #c ) 41 itempos2 ( .... #c #c p ) swap ( .... #c p #c ) 0 do ( .... #c p ) dup ( .... #c p p ) 2 pick ( .... #c p p #c ) i - 1- ( .... #c p p #c-i-1 ) 2* ( .... #c p p 2[#c-i-1] ) + ( .... #c p p+2[#c-i-1] ) -10000 swap - ( .... #c p -10000-[p+2[#c-i-1] ) group ( .... #c p W ) 2swap ( .... W #c p ) loop drop then ( ... Kn...K0 #k CxmCymCzm...Cx0Cy0Cz0 Wm...W0 #c ) \ Order 71 group 1+ ( ... Kn...K0 #k CxmCymCzm...Cx0Cy0Cz0 Wm...W0 #c order ) \ Set up flag to begin (true) or end (false). true setupspline clearitem writeitem drop \ Now vary the parameter from the value of the first to the last knot. 0.0 0.0 0.0 addPolylineHeader add3dPolylineHeader splineIterator @ 0 do i float knotInterval 2@ f* firstKnot 2@ f+ evalSpline addVertex addVertexTrailer loop addSequend \ Clean up any memory allocated by the interpreter. false setupspline ; : doLeader \ Decompose into polyline segments. saveLayer saveColor 10 itempos2 ( ... n ) 76 group 1- + ( ... n+[x-1] ) dup dup ( ... m m m ) 76 group 0 do ( ... m m m ) -10000 swap - ( ... m m -10000-m ) i + ( ... m m -10000-m+i ) group ( ... m m xx yy zz ) 3 2roll ( ... xx yy zz m m ) dup ( ... xx yy zz m m m ) loop drop drop drop 76 group ( .... xx yy zz xx yy zz p ) clearitem writeitem drop 0.0 0.0 0.0 addPolylineHeader 0 do ( .... xx yy zz xx yy zz ) addVertex ( .... xx yy zz ) loop addSequend ; : dxf:entities:leader doLeader ; : dxf:blocks:leader doLeader ; \ Termination processing : dxf:end handleson @ if \ No need to run a second pass if no new entities were added. needToRewind @ if \ Run 2 passes on the input file. \ This is done to increment the handle seed value back in the header. rewind @ if false rewind ! "End translation.\n" type else true rewind ! "End first pass, now updating handle values.\n" type then then then "m" option if \ If -M option is set, print memory stats memstat then depth if .s cr then ;