#!../wishx -f

# Program: shape (an autocad's shape to tk's canvas converter)
# Author:  Tuan T. Doan
# Date:    4/26/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 tdoan@x400gate.bnr.ca or tdoan@bnr.ca
#
# SHAPE format is copyrighted by Autodesk, Inc.
# =========================================================================

set auto_path ". $auto_path"

set gvar(unit) c
set gvar(stack) {}
set gvar(item) {}
set gvar(line) ""
set gvar(cx) 0; set gvar(cy) 0
set gvar(scalecanvas) 1

proc _push {value} {
   global gvar
   # the size of the stack is restricted to conform to autocad value
   if {[llength $gvar(stack)] > 4} {
#     puts stdout "ERROR: stack overflow"
   } else {
      lappend gvar(stack) $value
   }
}

proc _pop {} {
   global gvar
   if {$gvar(stack)==""} {
      return "0 0"
#     puts stdout "ERROR: stack underflow"
   } else {
      set l [expr {[llength $gvar(stack)]-1}]
      set t1 [lindex $gvar(stack) $l]
#     set gvar(stack) [lrange $gvar(stack) 0 [expr {$l-1}]] 
      lreplace $gvar(stack) $l $l
      return $t1
   }
}

proc _conv2polyline {coords} {
#  coords has the format:  {{line 1 1 2 2} {line 2 2 3 3} {line 4 4 5 5} ...}
#  will return: {{line 1 1 2 2 3 3} {line 4 4 ...} ...}
   set result {}
   set pts {}
   set type ""
   foreach i $coords {
      set type [lindex $i 0]
#     puts stdout "--> $type $i $px=$cx $py=$cy"
      if {$type=="line"} {
         set t2 [llength $pts]
         set px [lindex $pts [expr {$t2-2}]]
         set py [lindex $pts [expr {$t2-1}]]
         set t2 [expr {[llength $i]-1}]
         set cx [lindex $i 1]
         set cy [lindex $i 2]
         if {$px==$cx && $py==$cy} {
            append pts "[lrange $i 3 $t2] "
         } else {
            # handle the first element=line
            if {$pts==""} {
               append pts "[lrange $i 1 $t2] "
            } else {
               lappend result "line $pts"
               set pts "[lrange $i 1 $t2] "
            }
         }
      } else {
         # handle previous element=line
         if {$pts!=""} { lappend result "line $pts" }
         lappend result "$i "
         set pts ""
      }
   }
   if {$type=="line"} { lappend result "line $pts" }
#  puts stdout $result
   return $result
}

proc _findangle {t1} {
#  Take in (-)0SC  where S=start octant (0-7) and C=number of octant span
#  Return list {x1 y1 sa x2 y2 ea}   where x1 and y1 are unit coords of start
#  of arc and x2 and y2 are unit coords of end of arc, sa=start angle in degree
#  and da=the amount of the arc extend, not the ending angle
#  Did not use cos,sin because not everyone has tclX.
   global gvar
   set dx(0) 1;       set dy(0) 0
   set dx(1) 0.7071;  set dy(1) 0.7071
   set dx(2) 0;       set dy(2) 1
   set dx(3) -0.7071; set dy(3) 0.7071
   set dx(4) -1;      set dy(4) 0
   set dx(5) -0.7071; set dy(5) -0.7071
   set dx(6) 0;       set dy(6) -1
   set dx(7) 0.7071;  set dy(7) -0.7071
   set sl [expr "[string length $t1]-1"]
   set da [string index $t1 $sl]
   set sa [string index $t1 [expr "$sl-1"]]
   set x1 $dx($sa)
   set y1 $dy($sa)
   if {$da < 1} {set da 8}
#  puts stdout "sa=$sa da=$da"
   if {$t1 < 0} {
      set da [expr {-1 * $da}]
   }
   set ea [expr {($sa + $da) % 8}]
   set x2 $dx($ea)
   set y2 $dy($ea)
   return "$x1 $y1 [expr {$sa * 45}] $x2 $y2 [expr {$da * 45}]"
}

proc _addcoords {t1} {
   global gvar shape
   set dx [expr {[lindex $t1 0] * $gvar(scale)}]
   set dy [expr {[lindex $t1 1] * $gvar(scale)}]
   if {$gvar(pen)=="down"} {
      set x1 $gvar(cx)
      set y1 $gvar(cy)
      set gvar(cx) [expr {$x1+$dx}]
      set gvar(cy) [expr {$y1+$dy}]
      set t2 [concat line $x1$gvar(unit) [expr {-1 * $y1}]$gvar(unit) $gvar(cx)$gvar(unit) [expr {-1 * $gvar(cy)}]$gvar(unit)]
      lappend shape($gvar(shapeno)) $t2
   } else {
      set gvar(cx) [expr {$gvar(cx)+$dx}]
      set gvar(cy) [expr {$gvar(cy)+$dy}]
      set t2 "$gvar(cx)$gvar(unit) $gvar(cy)$gvar(unit)"
   }
   return $t2
}

proc _octantarc {} { 
   global gvar shape
   _getcode2; set r $gvar(code)
   _getcode2; set t1 $gvar(code)
   set t3 [_findangle $t1]
   set t2 $gvar(shapeno)
   set cx [expr {$gvar(cx) - $r * [lindex $t3 0]}]
   set cy [expr {$gvar(cy) - $r * [lindex $t3 1]}]
   set x1 [expr {$cx - $r}];  set y1 [expr {$cy - $r}]
   set x2 [expr {$cx + $r}];  set y2 [expr {$cy + $r}]
   set da [lindex $t3 5]
   if {$da < 360} {
      lappend shape($t2) [concat arc $x1$gvar(unit) [expr {-1*$y1}]$gvar(unit) $x2$gvar(unit) [expr {-1*$y2}]$gvar(unit) -start [lindex $t3 2] -extent $da -style arc -fill black]
      set gvar(cx) [expr {$cx + [lindex $t3 3]}]
      set gvar(cy) [expr {$cy + [lindex $t3 4]}]
   } else {
      lappend shape($t2) [concat oval $x1$gvar(unit) [expr {-1*$y1}]$gvar(unit) $x2$gvar(unit) [expr {-1*$y2}]$gvar(unit)]
      set gvar(cx) $cx
      set gvar(cy) $cy
   }
#  puts stdout "OCT-ARC ($r,$t1)"
}

proc _fractarc {} {
#  This functionality is hardly tested
#  People without tclX is out of luck because this procedure need sin,cos.
   global gvar shape
   _getcode2; set soff $gvar(code)
   _getcode2; set eoff $gvar(code)
   _getcode2; set hr   $gvar(code)
   _getcode2; set lr   $gvar(code)
   _getcode2; set t1   $gvar(code)
#  puts stdout "FRACT-ARC $soff,$eoff $hr$lr $t1"
   set t3 [_findangle $t1]
   set t2 $gvar(shapeno)
   set r [expr {256 * $hr + $lr}]
   set sa [lindex $t3 2]
   set da [expr {[lindex $t3 5] - 45}]
   set ea [expr {45.0 * $eoff / 256.0 + $da + $sa}]
   set sa [expr {45.0 * $soff / 256.0 + $sa}]
   set da [expr {$sa - $ea}]
#  puts stdout "   $r $soff $eoff $sa $ea $da"
   set rpd 0.017453293
   set dx [cos ([expr {$rpd * $sa}])]
   set dy [sin ([expr {$rpd * $sa}])]
   set cx [expr {$gvar(cx) - $r * $dx}]
   set cy [expr {$gvar(cy) - $r * $dy}]
   set x1 [expr {$cx - $r}];  set y1 [expr {$cy - $r}]
   set x2 [expr {$cx + $r}];  set y2 [expr {$cy + $r}]
#  puts stdout "   $x1 $y1 $x2 $y2 $dx $dy"
   lappend shape($t2) [concat arc $x1$gvar(unit) [expr {-1*$y1}]$gvar(unit) $x2$gvar(unit) [expr {-1*$y2}]$gvar(unit) -start $sa -extent $da -style arc -fill black]
   set dx [cos ([expr {$rpd * $ea}])]
   set dy [sin ([expr {$rpd * $ea}])]
   set gvar(cx) [expr {$cx + $r * $dx}]
   set gvar(cy) [expr {$cy + $r * $dy}]
}

proc _endshape {} {
   global gvar shape
   set t2 $gvar(shapeno)
#  puts stdout "$t2 $shape($t2,name): $shape($t2)"
}

proc _pendown {} {
   global gvar shape
   set gvar(pen) down
#  puts stdout "PENDOWN: $gvar(cx),$gvar(cy)"
}

proc _penup {} {
   global gvar shape
   set gvar(pen) up
#  puts stdout "PENUP: $gvar(cx),$gvar(cy)"
}

proc _scaledown {} {
   global gvar
   _getcode2
   set gvar(scale) [expr {1.0 * $gvar(scale) / $gvar(code)}]
#  puts stdout "1/SCALE: $gvar(scale)"
}

proc _scaleup {} {
   global gvar
   _getcode2
   set gvar(scale) [expr {1.0 * $gvar(scale) * $gvar(code)}]
#  puts stdout "SCALE: $gvar(scale)"
}

proc _pushstack {} {
   global gvar
   _push [list $gvar(cx) $gvar(cy)]
#  puts stdout "PUSH: $gvar(cx) $gvar(cy)"
}

proc _popstack {} {
   global gvar
   set t1 [_pop]
   set gvar(cx) [lindex $t1 0]
   set gvar(cy) [lindex $t1 1]
#  puts stdout "POP: $gvar(cx) $gvar(cy)"
}

proc _singlexy {} {
   global gvar
   _getcode2; set dx $gvar(code)
   _getcode2; set dy $gvar(code)
   _addcoords "$dx $dy"
#  puts stdout "DX-DY: $gvar(cx),$gvar(cy)"
}

proc _multixy {} {
   global gvar
#  puts stdout ".DX-DY: " nonewline
   _getcode2; set dx $gvar(code)
   _getcode2; set dy $gvar(code)
   while {$dx!="0" || $dy!="0"} {
      _addcoords "$dx $dy"
#     puts stdout "($gvar(cx),$gvar(cy)) " nonewline
      _getcode2; set dx $gvar(code)
      _getcode2; set dy $gvar(code)
   }
#  puts stdout ""
}

proc _singlebuldge {} {
   global gvar
   _getcode2; set dx $gvar(code)
   _getcode2; set dy $gvar(code)
   _getcode2; set t1 $gvar(code)
#  puts stdout "***BULDE-ARC: $dx $dy $t1"
}

proc _multibuldge {} {
   global gvar
#  puts stdout "***.BULDGE-ARC: " nonewline
   while {1} {
      _getcode2; set dx $gvar(code)
      _getcode2; set dy $gvar(code)
      if {$dx==0 && $dy==0} {break}
      _getcode2; set t1 $gvar(code)
#     puts stdout "($dx,$dy,$t1) " nonewline
   }
#  puts stdout ""  
}

proc _subshape {fd} {
   global gvar shape
   _getcode1 $fd; set t1 [format "*%d" $gvar(code)]
   set t2 $gvar(shapeno)
   if {![info exists shape($t1)]} {puts stdout "SUBSHAPE: err $t1"; return}
   set t3 $gvar($t1,command)
   if {$t3==""} { return "" }
   set l  [expr {[llength $t3]-1}]
   set t3 [lreplace $t3 $l $l]
#  puts stdout "SUBSHAPE: $t1 $t3 -> $t2"
   if {$gvar(pen)=="up"} {set t4 2} {set t4 ""}
   return "1 $t3 $t4"
}

proc _move {mag dir} {
   global gvar
   case $dir in {
   {0}   {set dx 1;    set dy 0}
   {1}   {set dx 1;    set dy 0.5}
   {2}   {set dx 1;    set dy 1}
   {3}   {set dx 0.5;  set dy 1}
   {4}   {set dx 0;    set dy 1}
   {5}   {set dx -0.5; set dy 1}
   {6}   {set dx -1;   set dy 1}
   {7}   {set dx -1;   set dy 0.5}
   {8}   {set dx -1;   set dy 0}
   {9}   {set dx -1;   set dy -0.5}
   {A a} {set dx -1;   set dy -1}
   {B b} {set dx -0.5; set dy -1}
   {C c} {set dx 0;    set dy -1}
   {D d} {set dx 0.5;  set dy -1}
   {E e} {set dx 1;    set dy -1}
   {F f} {set dx 1;    set dy -0.5}
   }
   set vl [format "%d" 0x$mag]
   set dx [expr {$vl * $dx}]
   set dy [expr {$vl * $dy}]
   _addcoords "$dx $dy"
#  puts stdout "MOVE: ${vl}(${dx},${dy})"
}

proc _processcode {} {
#  split $gvar(code) which is in 0x?? format to upper nibble and lower nibble

   global gvar shape
   set t3 [_convertcode $gvar(code)]
   set hn [string index $t3 2]
   set ln [string index $t3 3]
#  puts stdout "hn=$hn ln=$ln: " nonewline
   case $hn in {
   {0}  {case $ln in {
         {0}   { _endshape }
         {1}   { _pendown }
         {2}   { _penup }
         {3}   { _scaledown }
         {4}   { _scaleup }
         {5}   { _pushstack }
         {6}   { _popstack }
         {7}   { puts stdout "SUBSHAPE: err" }
         {8}   { _singlexy }
         {9}   { _multixy }
         {A a} { _octantarc }
         {B b} { _fractarc }
         {C c} { _singlebuldge }
         {D d} { _multibuldge}
         {E e} { 
#               puts stdout "***VTEXT: $gvar(code)" 
               }
        }}
   default { _move $hn $ln }
   }
}

proc _code {fd} {
   global gvar shape
   set t1 $gvar(shapeno)
   set t2 {}
   while {! [eof $fd]} {
      set t3 [_convertcode $gvar(code)]
      set hn [string index $t3 2]
      set ln [string index $t3 3]
      case $hn in {
      {0}  {case $ln in {
            {0}           { lappend t2 $gvar(code)
                            break 
                          }
            {1 2 5 6 E e} { lappend t2 $gvar(code) }
            {3 4}         { lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                          }
            {7}           { append t2 [_subshape $fd]
#                           lappend t2 $gvar(code)
#                           _getcode1 $fd; set x $gvar(code); lappend t2 $x
                          }
            {9}           { lappend t2 $gvar(code)
                            _getcode1 $fd; set x $gvar(code); lappend t2 $x
                            _getcode1 $fd; set y $gvar(code); lappend t2 $y
                            while {$x!=0 || $y!=0} {
                               _getcode1 $fd; set x $gvar(code); lappend t2 $x
                               _getcode1 $fd; set y $gvar(code); lappend t2 $y
                            }
                          }
            {8 A a}       { lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                          }
            {B b}         { lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                          }
            {C c}         { lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                            _getcode1 $fd; lappend t2 $gvar(code)
                          }
            {D d}         { lappend t2 $gvar(code)
                            while {! [eof $fd]} {
                               _getcode1 $fd; set x $gvar(code); lappend t2 $x
                               _getcode1 $fd; set y $gvar(code); lappend t2 $y
                               if {$x==0 && $y==0} { break }
                               _getcode1 $fd; set w $gvar(code); lappend t2 $w
                            }
                          }
           }}
      default { lappend t2 $gvar(code) }
      }
      _getcode1 $fd
   }
   set gvar($t1,command) $t2
#  puts stdout "CODE: $t1 $gvar($t1,command)"
}

proc _convertcode {t2} {
   global gvar
   case $t2 in {
   {0}        {set t2 "0x00"}
   {0*}       {regsub {^0} $t2 {} t2; set t2 "0x$t2"}
   {[1-9]*}   {set t2 "0x[format "%02x" $t2]"}
   {-[1-9]*}  {set t2 "0x[format "%02x" $t2]"}
   {+[1-9]*}  {set t2 "0x[format "%02x" $t2]"}
   default    {}
   }
#  puts stdout ">$t2<"
   return $t2
}

proc _getcode2 {} {
   global gvar
   set t2 [lindex $gvar(line) 0]
   set gvar(line) [lrange $gvar(line) 1 end]
   set gvar(code) $t2
}

proc _getcode1 {fd} {
   global gvar
   set t1 [llength $gvar(line)]
   if {$t1<1} {
      set t1 [gets $fd gvar(line)]
      regsub -all {\,} $gvar(line) { } gvar(line)
      regsub -all {\(} $gvar(line) { } gvar(line)
      regsub -all {\)} $gvar(line) { } gvar(line)
   }
   _getcode2
#  gotta return the size of line read, -1 mean eof
   return $t1
}

proc _header {fd} {
   global gvar shape
   set gvar(shapeno) $gvar(code)
   set gvar($gvar(shapeno),command) {}
   set gvar(pen) down
   set shape($gvar(shapeno),length) [lindex $gvar(line) 0]
   set shape($gvar(shapeno),name)   [lrange $gvar(line) 1 end]
   set shape($gvar(shapeno)) {}
   .l.list insert end "$gvar(code) $shape($gvar(code),name)"
   set gvar(line) ""
}

proc _rscale {sr} {
   global gvar 
   set gvar(scalecanvas) $sr
   if {$sr==0} {set gvar(scalecanvas) 1}
   if {$sr<0} {set gvar(scalecanvas) [expr {-1.0/$sr}]}
   .f.c scale all 0.0 0.0 $gvar(scalecanvas) $gvar(scalecanvas)
   set t1 "[.f.c bbox all]"
   if {$t1!=""} {
      .f.c configure -scrollregion "$t1"
      scan $t1 "%d %d %d %d" x1 y1 x2 y2
      .f.c xview [expr "($x2-$x1)/2"]
      .f.c yview [expr "($y2-$y1)/2"]
   }
}

proc _drawshape {} {
   global gvar shape
   .f.c delete all
   set node  [.l.list get [.l.list curselection]]
   set t1 [lindex $node 0]
   set gvar(shapeno) $t1
   set gvar(line) $gvar($t1,command)
   set gvar(scale) 1
   set gvar(coords) {}
   set gvar(pen) down
   set gvar(cx) 0; set gvar(cy) 0
   set shape($t1) {}
   while {$gvar(line)!=""} {
      _getcode2
      _processcode
   }
   foreach i [_conv2polyline $shape($t1)] {
      eval ".f.c create $i -tags \"$t1 $shape($t1,name)\""
   }
   _rscale $gvar(scalecanvas)
}

wm minsize . 100 100
frame .f
   canvas    .f.c -scrollregion "-10 -10 10 10" \
      -xscroll ".f.hs set" -yscroll ".f.vs set"
   scrollbar .f.vs -relief sunken -command ".f.c yview"
   scrollbar .f.hs -relief sunken -orient horiz -command ".f.c xview"
pack append .f .f.hs {bottom fillx} \
               .f.vs {right filly} \
               .f.c  {expand fill}
frame .l
   listbox   .l.list -relief sunken -xscroll ".l.hs set" -yscroll ".l.vs set" \
      -export 0 -geometry 10x5
   bind .l.list <Double-Button-1> "_drawshape"
   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 -10 -to 10 -orient horiz \
      -command "_rscale"
   .s.sr set 1
pack append .s .s.sr {top fillx}

pack append . .f {fill expand} \
              .l {fill} \
              .s {fill}
              
set fd [open "$argv" r]
while {[_getcode1 $fd] > -1} {
   case $gvar(code) in {
   {\**}   {_header $fd}
   default {_code $fd}
   }
}
close $fd
foreach i [array names shape] {
   case $i in {
   {*,*} { continue }
   }
   set gvar(shapeno) $i
   set gvar(line) $gvar($i,command)
   set gvar(scale) 1
   set gvar(coords) {}
   set gvar(pen) down
   set gvar(cx) 0; set gvar(cy) 0
   set shape($i) {}
   while {$gvar(line)!=""} {
      _getcode2
      _processcode
   }
   puts stdout "$i [_conv2polyline $shape($i)]"
}
