Here is the script dxf.tcl from Tcad 2.0b : http://www.neosoft.com/tcl/ftparchive/sorted/packages-7.6/graphics/tdcad2.0b/ If the previous link is broken, try this one: ftp://ftp.uni-hannover.de/pub/mirror/tcl/mirror/ftp.procplace.com/alcatel/code/tdcad2.0b.tar.gz # Program: dxf (an autocad's dxf to tk's canvas converter) # Author: Tuan T. Doan # Date: 4/20/93 # ========================================================================= # Copyright 1993 Tuan T. Doan # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies. Tuan # Doan make no representations about the suitability of this software # for any purpose. It is provided "as is" without express or implied # warranty. If you do use any part of the software, I would like to # know about it. Please send me mail at tdoan@bnr.ca # # DXF format is copyrighted by Autodesk, Inc. # ========================================================================= set auto_path ". $auto_path" set gvar(unit) p set gvar(scale) 1.0 proc _gettuple {fd} { # read in two lines; first line = groupcode, second line = groupvalue global gvar set gvar(groupcode) [string trim [gets $fd]] set gvar(groupvalue) [string trim [gets $fd]] # puts stdout "$gvar(groupcode) $gvar(groupvalue) - " nonewline } proc _circle {fd} { # we already read: 0,CIRCLE ; continue to read in circle info until see 0 # interested in: 10=xcenter, 20=ycenter, 40=radius global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return "[expr $x-$r]$gvar(unit) [expr $y-$r]$gvar(unit) [expr $x+$r]$gvar(unit) [expr $y+$r]$gvar(unit) -outline black"} {10} {set x $gvar(groupvalue)} {20} {set y [expr {-1 * $gvar(groupvalue)}]} {40} {set r $gvar(groupvalue)} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _line {fd} { # we already read: 0,LINE ; continue to read in line info until see 0 # interested in: 10=xpoint1, 20=ypoint1, 11=xpoint2, 21=ypoint2 global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return "${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) -fill black"} {10} {set x1 $gvar(groupvalue)} {20} {set y1 [expr {-1 * $gvar(groupvalue)}]} {11} {set x2 $gvar(groupvalue)} {21} {set y2 [expr {-1 * $gvar(groupvalue)}]} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _triangle {fd} { # we already read: 0,3DFACE ; continue to read in surface info until see 0 # interested in: 10=xpoint1, 20=ypoint1, 11=xpoint2, 21=ypoint2 # 12=xpoint3, 22=ypoint3, 13=xpoint3, 23=ypoint3 # if last point 3 is same as point 4, we want only points 1-3 global gvar set x1 ""; set x2 ""; set x3 ""; set x4 "" set y1 ""; set y2 ""; set y3 ""; set y4 "" while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {if {$x3==$x4 && $y3==$y4} { puts stdout "3dtri" # return "polygon ${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) ${x3}$gvar(unit) ${y3}$gvar(unit) -fill white" return "line ${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) ${x3}$gvar(unit) ${y3}$gvar(unit) -fill black" } else { puts stdout "3dpoly" # return "polygon ${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) ${x3}$gvar(unit) ${y3}$gvar(unit) ${x4}$gvar(unit) ${y4}$gvar(unit) -fill white" return "line ${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) ${x3}$gvar(unit) ${y3}$gvar(unit) ${x4}$gvar(unit) ${y4}$gvar(unit) -fill black" } } {10} {set x1 $gvar(groupvalue)} {20} {set y1 [expr {-1 * $gvar(groupvalue)}]} {11} {set x2 $gvar(groupvalue)} {21} {set y2 [expr {-1 * $gvar(groupvalue)}]} {12} {set x3 $gvar(groupvalue)} {22} {set y3 [expr {-1 * $gvar(groupvalue)}]} {13} {set x4 $gvar(groupvalue)} {23} {set y4 [expr {-1 * $gvar(groupvalue)}]} {70} {puts stdout "Invisible edge: $gvar(groupvalue)"} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _arc {fd} { # we already read: 0,ARC ; continue to read in arc info until see 0 # interested in: 10=xcenter, 20=ycenter, 40=radius, 50=startangle, 51=endangle global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return "[expr $x-$r]$gvar(unit) [expr $y-$r]$gvar(unit) [expr $x+$r]$gvar(unit) [expr $y+$r]$gvar(unit) -start $sa -extent [expr $sa-$ea] -style arc -fill black"} {10} {set x $gvar(groupvalue)} {20} {set y [expr {-1 * $gvar(groupvalue)}]} {40} {set r $gvar(groupvalue)} {50} {set sa $gvar(groupvalue)} {51} {set ea $gvar(groupvalue)} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _trace {fd} { # we already read: 0,TRACE ; continue to read in thick line info until see 0 # interested in: 10=xpoint1, 20=ypoint1, 11=xpoint2, 21=ypoint2 # 12=xpoint3, 22=ypoint3, 13=xpoint4, 13=ypoint4 global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return "${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) ${x3}$gvar(unit) ${y3}$gvar(unit) ${x4}$gvar(unit) ${y4}$gvar(unit) -fill black"} {10} {set x1 $gvar(groupvalue)} {20} {set y1 [expr {-1 * $gvar(groupvalue)}]} {11} {set x2 $gvar(groupvalue)} {21} {set y2 [expr {-1 * $gvar(groupvalue)}]} {12} {set x3 $gvar(groupvalue)} {22} {set y3 [expr {-1 * $gvar(groupvalue)}]} {13} {set x4 $gvar(groupvalue)} {23} {set y4 [expr {-1 * $gvar(groupvalue)}]} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _solid {fd} { # we already read: 0,SOLID ; continue to read in triangle or quad until see 0 # interested in: 10=xpoint1, 20=ypoint1, 11=xpoint2, 21=ypoint2 # 12=xpoint3, 22=ypoint3, 13=xpoint4, 13=ypoint4 # if we get only three points, the 4th pts will be the same as the third pts global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return "${x1}$gvar(unit) ${y1}$gvar(unit) ${x2}$gvar(unit) ${y2}$gvar(unit) ${x3}$gvar(unit) ${y3}$gvar(unit) ${x4}$gvar(unit) ${y4}$gvar(unit) -fill \"\""} {10} {set x1 $gvar(groupvalue)} {20} {set y1 [expr {-1 * $gvar(groupvalue)}]} {11} {set x2 $gvar(groupvalue)} {21} {set y2 [expr {-1 * $gvar(groupvalue)}]} {12} {set x3 $gvar(groupvalue); set x4 $x3} {22} {set y3 [expr {-1 * $gvar(groupvalue)}]; set y4 $y3} {13} {set x4 $gvar(groupvalue)} {23} {set y4 [expr {-1 * $gvar(groupvalue)}]} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _vertex {fd} { # we already read: 0,VERTEX ; continue to read in point info until see 0 # interested in: 10=xpoint, 20=ypoint global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return "${x}$gvar(unit) ${y}$gvar(unit)"} {10} {set x $gvar(groupvalue)} {20} {set y [expr {-1 * $gvar(groupvalue)}]} {70} {puts stdout "vertex flag = $gvar(groupvalue)"} {42} {puts stdout "vertex bludge = $gvar(groupvalue)"} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _conv2rect {coords} { # check to see if the polyline can be converted to a rectangle; this happen # if we get 4 points and polyflag=1 (indicate closed polygon) # if we get 5 points and the 5th point is the same as the 1st point global gvar if {$gvar(polyflag)=="1" || ([lindex $coords 0]==[lindex $coords 8] && [lindex $coords 1]==[lindex $coords 9])} { puts stdout "rect" return "rectangle [lindex $coords 0] [lindex $coords 1] [lindex $coords 4] [lindex $coords 5] -fill \"\"" } else { return "line $coords -fill black" } } proc _polyline {fd} { # we already read: 0,POLYLINE ; continue to read in points info (0,VERTEX) # until see 0,SEQEND. if we see groupcode=70 set polyflag to groupvalue so # that we can later determine if polygon is closed global gvar set result "" set np 0 set gvar(polyflag) "" _gettuple $fd while {! [eof $fd]} { case $gvar(groupcode) in { {0} {case $gvar(groupvalue) in { {VERTEX} {incr np; append result " [_vertex $fd]"} {SEQEND} {if {$np<2} {puts stdout "ERROR: no of pts in polyline is $np"; exit 1} _gettuple $fd if {$gvar(polyflag)==1} { return "polygon $result -fill black" } else { if {$np==4 || $np==5} { return [_conv2rect $result] } else { return "line $result -fill black" } } } } } {70} {set gvar(polyflag) $gvar(groupvalue) puts stdout "polyflag = $gvar(polyflag)" _gettuple $fd} {62} {set gvar(color) $gvar(groupvalue); _gettuple $fd} {40} {set gvar(swidth) $gvar(groupvalue); _gettuple $fd} {41} {set gvar(ewidth) $gvar(groupvalue); _gettuple $fd} {71} {set gvar(mcount) $gvar(groupvalue); _gettuple $fd} {72} {set gvar(ncount) $gvar(groupvalue); _gettuple $fd} {73} {set gvar(mdensity) $gvar(groupvalue); _gettuple $fd} {74} {set gvar(ndensity) $gvar(groupvalue); _gettuple $fd} default {_gettuple $fd} } } } proc _text {fd} { # we already read: 0,TEXT ; continue to read in text info # interested in: 10=xpos, 20=ypos, 1=textstring global gvar while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} { if {$x=="0." && $y=="-1.5"} { return "${x}$gvar(unit) ${y}$gvar(unit) -text \"$t\" -fill black" } else { return "${x}$gvar(unit) ${y}$gvar(unit) -text \"$t\" -fill black" } } {10} {set x $gvar(groupvalue)} {20} {set y [expr {-1 * $gvar(groupvalue)}]} {1} {set t $gvar(groupvalue)} {40} {set h $gvar(groupvalue)} {50} {set ra $gvar(groupvalue)} {51} {set oa $gvar(groupvalue)} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _insert {fd} { # we already read: 0,INSERT ; continue to read in info on what and where to # insert. each block to be inserted will be encapsulated in a list consisting # of: {block_name xpos ypos xscale yscale angle attr} # currently only interested in: block_name, xpos, ypos, xscale, yscale global gvar set bname "";set x "";set y "";set sx 1.;set sy 1.;set ra 0;set attr 0 while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {return [list $bname $x $y $sx $sy $ra $attr]} {66} {set attr $gvar(groupvalue)} {2} {set bname $gvar(groupvalue)} {10} {set x $gvar(groupvalue)} {20} {set y [expr {-1 * $gvar(groupvalue)}]} {41} {set sx $gvar(groupvalue)} {42} {set sy $gvar(groupvalue)} {50} {set ra $gvar(groupvalue)} {62} {set gvar(color) $gvar(groupvalue)} } } } proc _insertblock {{parent}} { # the data for block (grouped-data) are stored in the global array 'block'. # the block name is used as index to 'block' and 'binsert' array. the # 'binsert' array is use to store list of block name associated with that # block. yep, blocks can be nested. this procedure will extract and display # the block in a canvas. # example: block(table1)={{line ...} {circle ...} {text ...} ...} # binsert(table1)={{leg 5 15 .4 .5 0 0} {leg 15 15 .4 .5 0 0} ...} # binsert(leg)={{line ...} {line ...} ...} global block binsert foreach j $binsert($parent) { set n [lindex $j 0] set x [lindex $j 1] set y [lindex $j 2] set sx [lindex $j 3] if {$sx < 0.0} {set sx [expr "-1 * $sx"]; puts stdout "-XSCALE"} set sy [lindex $j 4] if {$sy < 0.0} {set sy [expr "-1 * $sy"]; puts stdout "-YSCALE"} if {! [info exists binsert($n)]} {puts stdout "? $j"; return} if {$binsert($n)==""} { foreach i $block($n) { eval ".c.c create $i -tags \"$parent $parent:insert\"" .c.c scale $parent:insert 0.0 0.0 $sx $sy .c.c move $parent:insert $x $y # .c.c coords $parent:insert $x $y } } else { _insertblock $n } } } proc _getelement {fd} { # check to see if the already read groupcode,groupvalue is one of the elements # we want to handle. if we get a 0,VERTEX outside POLYLINE or 0,POINT we # do a very small circle (OVAL x1 y1 x1 y1). currently this is used to get # elements in the block. the only way that this procedure will return is that # it must encounter one of the listed elements. global gvar while {! [eof $fd]} { # puts stdout "$gvar(groupcode) $gvar(groupvalue)" case $gvar(groupcode) in { {0} {case $gvar(groupvalue) in { {LINE} {return "line [_line $fd]"} {3DLINE} {return "line [_line $fd]"} {CIRCLE} {return "oval [_circle $fd]"} {ARC} {return "arc [_arc $fd]"} {3DFACE} {return "[_triangle $fd]"} {POLYLINE} {return "[_polyline $fd]"} {TRACE} {return "line [_trace $fd]"} {SOLID} {return "polygon [_solid $fd]"} {POINT} {set t1 [_vertex $fd]; return "oval $t1 $t1"} {VERTEX} {set t1 [_vertex $fd]; return "oval $t1 $t1"} {TEXT} {return "text [_text $fd]"} default {_gettuple $fd} } } default {_gettuple $fd} } } } proc _block {fd} { # we already read: 0,BLOCK ; continue to read in info until 0,ENDBLK # if we see 2,? it means this is the name of this block # if we see 0,INSERT then build the binsert appropriately # if we see 0,? then extract the element by calling _getelement and add it to # the list to be returned. # if we see 0,ENDBLK we set the global variables: block and binsert # binsert could be an empty list if there is no nested block(s) global gvar block binsert set r1 {} set r2 {} _gettuple $fd while {! [eof $fd]} { # puts stdout "$gvar(groupcode) $gvar(groupvalue)" if {$gvar(groupcode)=="0" && \ $gvar(groupvalue)=="INSERT"} {lappend r2 [_insert $fd]} case $gvar(groupcode) in { {0} {case $gvar(groupvalue) in { {ENDBLK} {set block($t1) $r1 set binsert($t1) $r2 # puts stdout block($t1) return $t1} default {lappend r1 [_getelement $fd]} } } {70} {_gettuple $fd} {2} {set t1 $gvar(groupvalue); set binsert($t1) {}; set r2 {}; _gettuple $fd} default {_gettuple $fd} } } } proc _entities {fd} { # we already read: 0,ENTITIES ; continue to read in info until 0,ENDSEC # global gvar binsert set binsert(main) {} _gettuple $fd while {! [eof $fd]} { # puts stdout "$gvar(groupcode) $gvar(groupvalue)" if {$gvar(groupcode)=="0" && $gvar(groupvalue)=="INSERT"} { lappend binsert(main) [_insert $fd] # set binsert(main) [list [_insert $fd]] # _insertblock main } case $gvar(groupcode) in { {0} {case $gvar(groupvalue) in { {ENDSEC} {return} {LINE} {set t5 ".c.c create line [_line $fd]" eval "$t5 -tags obj" } {3DLINE} {set t5 ".c.c create line [_line $fd]" eval "$t5 -tags obj" } {CIRCLE} {set t5 ".c.c create oval [_circle $fd]" eval "$t5 -tags obj" } {ARC} {set t5 ".c.c create arc [_arc $fd]" eval "$t5 -tags obj" } {TRACE} {set t5 ".c.c create line [_trace $fd]" eval "$t5 -tags obj" } {SOLID} {set t5 ".c.c create polygon [_solid $fd]" eval "$t5 -tags obj" } {POINT} {set p1 [_vertex $fd] set t5 ".c.c create oval $p1 $p1" eval "$t5 -tags obj" } {VERTEX} {set p1 [_vertex $fd] set t5 ".c.c create oval $p1 $p1" eval "$t5 -tags obj" } {3DFACE} {set t5 ".c.c create [_triangle $fd]" eval "$t5 -tags obj" } {POLYLINE} {set t5 ".c.c create [_polyline $fd]" eval "$t5 -tags obj" } {TEXT} {set t5 ".c.c create text [_text $fd]" eval "$t5 -tags obj" } default {_gettuple $fd} } } default {_gettuple $fd} } } } proc _drawblock {} { global gvar block binsert .c.c delete all set node [.l.list get [.l.list curselection]] puts stdout "$node: $binsert($node)" foreach i $block($node) { # puts stdout " $i" eval ".c.c create $i -tags $node" } if {$binsert($node)!=""} {_insertblock $node} } proc _rscale {sr} { global gvar puts stderr "SCALING: $sr - $gvar(scale)" .c.c scale all 0.0 0.0 $sr $sr set gvar(scale) [expr $gvar(scale) * $sr] set t1 "[.c.c bbox all]" if {$t1!=""} {.c.c configure -scrollregion "$t1"} } proc _dumpobj {c tag} { global argv set fname [file root [file tail $argv]] set fd [open $fname.tkobj w+] foreach j [$c find withtag $tag] { set opt {} foreach i [$c itemconfig $j] { if {[llength $i]==5 && [lindex $i 3]!=[lindex $i 4]} { lappend opt [lindex $i 0] lappend opt [lindex $i 4] } } set t1 [concat "$c create [$c type $j]" [$c coords $j] $opt] puts $fd "$t1" lappend result $t1 } close $fd } wm minsize . 100 100 frame .c canvas .c.c -scrollregion "-800 -600 700 600" \ -xscrollcommand ".c.hs set" -yscrollcommand ".c.vs set" scrollbar .c.vs -relief sunken -command ".c.c yview" scrollbar .c.hs -relief sunken -orient horiz -command ".c.c xview" pack append .c .c.hs {bottom fillx} \ .c.vs {right filly} \ .c.c {expand fill} frame .l listbox .l.list -relief sunken -xscrollcommand ".l.hs set" -yscrollcommand ".l.vs set" \ -export 0 bind .l.list "_drawblock" scrollbar .l.hs -command ".l.list xview" -orient horiz -relief sunken scrollbar .l.vs -command ".l.list yview" -relief sunken pack append .l .l.vs {right filly} \ .l.hs {bottom fillx} \ .l.list {left fill expand} \ frame .s scale .s.sr -label "SCALE" -from 1 -to 100 -orient horiz \ -command "_rscale" pack append .s .s.sr {top fillx} frame .com button .com.b1 -bd 5 -text "PRINT" -command "_canvasprint .c.c" button .com.b2 -bd 5 -text "DUMP" -command "_dumpobj .c.c all" button .com.b3 -bd 5 -text "QUIT" -command "destroy ." button .com.b4 -bd 5 -text "NORMAL" -command {_rscale [expr 1.0/$gvar(scale)]} pack append .com .com.b4 {left expand fillx} \ .com.b1 {left expand fillx} \ .com.b2 {left expand fillx} \ .com.b3 {left expand fillx} pack append . .c {fill expand} \ .l {fill} \ .s {fill} \ .com {fillx} set gvar(section) 0 set fd [open "$argv" r] set gvar(lineno) 1 set noblock 0 while {! [eof $fd]} { _gettuple $fd case $gvar(groupcode) in { {0} {case $gvar(groupvalue) in { {BLOCK} {set t1 [_block $fd] .l.list insert end $t1 puts stdout "$t1: $binsert($t1)" incr noblock # if {$noblock>5} {break} } } } {2} {case $gvar(groupvalue) in { {ENTITIES} {_entities $fd; _insertblock main} {HEADER TABLES BLOCKS ENTITIES} {set gvar(sname) $gvar(groupvalue)} } } } } close $fd #foreach i [array names block] { # if {$binsert($i)!=""} {_insertblock $i} #}