#!/bnr/bootleg/bin/tcl/wishx -f

# Program: tdcad (a vector drawing program)
# Author:  Tuan T. Doan
# Date:    5/10/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
#
# DXF format is copyrighted by Autodesk, Inc.
# Hershey font was originally created by Dr. A. V. Hershey; format of the
#    font was distributed by James Hurt; converted to tk canvas item by
#    Tuan T. Doan
# =========================================================================

set gvar(HOME) /bnr/bootleg/bin/tcl/cad
source $gvar(HOME)/print.tcl
source $gvar(HOME)/util.tcl

# source sincostan.tcl

set gvar(obj) line
set gvar(coords) {}
set gvar(pat) 0
set gvar(linepat) \"\"
set gvar(fill) \"\"
set gvar(width) 1
set gvar(arrowshape) {8 10 3}
set gvar(arrowloc) none
set gvar(capstyle) butt
set gvar(joinstyle) miter
set gvar(tfontanchor) nw
set gvar(tfontjust) left
set gvar(tfontname) courier
set gvar(tfontweight) medium
set gvar(tfontslant) r
set gvar(tfontpoint) 10
set gvar(tfont) -*-courier-medium-r-normal--*-100-*
set gvar(tracemode) line
set gvar(bitmapanchor) c
set gvar(cx) 0
set gvar(cy) 0
set gvar(xylabel) "($gvar(cx),$gvar(cy))"
set gvar(gridx) 20
set gvar(gridy) 10
set gvar(pside) 8
set gvar(oscale) 1
set gvar(oscaletype) abs
set gvar(orotate) 45
set gvar(osnap) normal
set gvar(osavefile) "test1.tkobj"
set gvar(oloadfile) "test1.tkobj"
set gvar(ocutbuffer) {}
set gvar(onopick) 0
set gvar(onocut) 0
set gvar(opattern) normal
set gvar(oarcstyle) arc

proc _rot {a cp p} {
   set rpd 0.017453293
   set a [expr {-1*[tan {$a*$rpd/2.0}]}]
   set b [expr {-2*$a/(1+$a*$a)}]

   set tx [expr {[lindex $p 0]-[lindex $cp 0]}]
   set ty [expr {[lindex $p 1]-[lindex $cp 1]}]

   set x1 [expr {$tx+$a*$ty}]
   set y1 [expr {$ty+$b*$x1}]
   set x1 [expr {$x1+$a*$y1}]

   set tx [expr {$x1+[lindex $cp 0]}]
   set ty [expr {$y1+[lindex $cp 1]}]
   return "$tx $ty"
}

proc _closestpoint {c item coords} {
   set ll [llength [$c coords $item]]
   set x [lindex $coords 0]
   set y [lindex $coords 1]
   set rx $x
   set ry $y
   set dist 100000
   for {set i 0} {$i < $ll} {incr i 2} {
      set ix [lindex [$c coords $item] $i]
      set iy [lindex [$c coords $item] [expr $i+1]]
      set dx [expr {$x-$ix}]
      set dy [expr {$y-$iy}]
      set idist [expr $dx*$dx+$dy*$dy]
      if {$idist < $dist} {
         set rx $ix
         set ry $iy
         set dist $idist
      }
   }
   return "$rx $ry"
}

proc _getangle {dx dy} {
   global gvar
   set ta 90
   if {$dx!=0} {
      set ta [atan {1.0*$dy/$dx}]
      set ta [expr $ta*57.29578]
   }
   if {$dy>0} {
      if {$dx<0} {
         set ta [expr 180+$ta]
      }
   } else {
      if {$dx<=0} {
         set ta [expr 180+$ta]
      } else { 
         set ta [expr 360+$ta]
      }
   }
   return $ta
}

proc _drawcursor {c coords} {
   global gvar
   set x [$c canvasx [lindex $coords 0]]
   set y [$c canvasy [lindex $coords 1]]
   case $gvar(osnap) {
      {grid} {
         set gvar(cx) [expr {$x/$gvar(gridx)*$gvar(gridx)}]
         set gvar(cy) [expr {$y/$gvar(gridy)*$gvar(gridy)}]
      }
      {gravity} {
         set t1 [$c find closest $x $y 10]
         if {$t1!="1" && $t1!="2"} {
            set t2 [_closestpoint $c $t1 "$x $y"]
            set gvar(cx) [lindex $t2 0]
            set gvar(cy) [lindex $t2 1]
         } else {
            set gvar(cx) $x
            set gvar(cy) $y
         }
      }
      default {
         set gvar(cx) $x
         set gvar(cy) $y
      }
   }
   set gvar(xylabel) "($gvar(cx),$gvar(cy))"
   scan [$c coords xhair] "%f %f %f %f" x1 y1 x2 y2
   $c coords xhair $x1 $gvar(cy) $x2 $gvar(cy)
   scan [$c coords yhair] "%f %f %f %f" x1 y1 x2 y2
   $c coords yhair $gvar(cx) $y1 $gvar(cx) $y2
   if {[llength $gvar(coords)] > 0} {
      case $gvar(tracemode) in {
         {line} { 
            scan [$c coords trace] "%f %f %f %f" x1 y1 x2 y2
            $c coords trace $x1 $y1 $gvar(cx) $gvar(cy)
         }
         {rect} {
            set t2 [lindex $gvar(coords) 0]
            set x1 [lindex $t2 0]
            set y1 [lindex $t2 1]
            $c delete trace
            $c create rectangle $x1 $y1 $gvar(cx) $gvar(cy) -tags "trace" \
               -width $gvar(width)
         }
      }
   }
}

proc _restore {c} {
   global gvar
   if {$gvar(coords)!=""} {
      $c dtag pick pick
      $c delete trace trace2
      set gvar(coords) ""
   }
}

proc _dumpobj {c tag fd} {
   global gvar
   foreach j [$c find withtag $tag] {
      set opt {}
      foreach i [$c itemconfig $j] {
         if {[llength $i]==5 && [lindex $i 3]!=[lindex $i 4]} {
            set t1 [lindex $i 4]
            regsub -all \n $t1 \033 t1
            lappend opt [lindex $i 0] $t1
         }
      }
      set t1 [concat "$c create [$c type $j]" [$c coords $j] $opt]
      puts $fd "$t1"
      lappend result $t1
   }
   return $result
}

proc _cutobj {c} {
   global gvar
   set gvar(ocutbuffer) {}
   foreach i [$c find withtag pick] {
      lappend gvar(ocutbuffer) $i
   }
   set gvar(onocut) [llength $gvar(ocutbuffer)]
#  $c dtag pick
#  $c delete trace
}

proc _pasteobj {c coords} {
   global gvar
   set x1 [lindex $coords 0]
   set y1 [lindex $coords 1]
   $c dtag pick
   foreach j $gvar(ocutbuffer) {
      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 [eval "$c create [$c type $j] [$c coords $j] $opt"]
      $c move $t1 $x1 $y1
      $c addtag pick withtag $t1
   }
   $c delete trace
   _boundingbox $c pick
}

proc _saveit {c} {
   global gvar
   set gvar(dialogrc) 0
   if {[file exists $gvar(osavefile)]} {
      _mkdialog .dm {-text {INFO: file exist! Overwrite?} -aspect 500} \
         {{NO  "destroy .dm"}
          {YES "destroy .dm"}}
         
   }
   if {$gvar(dialogrc)==0 || $gvar(dialogrc)==2} {
      set fd [open $gvar(osavefile) w+] 
      _dumpobj $c obj $fd
      close $fd
   }
}

proc _save {c} {
   # gotta merge _save and _load into something like _getfile
   global gvar
   set f .saveframe
   catch {destroy $f}
   toplevel $f
   wm title $f "Save Options"
   frame $f.f1
      label $f.f1.1 -text "File Name" -width 10 
      entry $f.f1.2 -relief sunken -width 20 -textvariable gvar(osavefile)
   pack append $f.f1 $f.f1.1 {left} \
                     $f.f1.2 {left}
   bind $f.f1.2 <Return> "destroy $f; _saveit $c"

   frame $f.f2
      button $f.f2.1 -bd 5 -text "APPLY"  -command "destroy $f; _saveit $c"
      button $f.f2.2 -bd 5 -text "CANCEL" -command "destroy $f"
   pack append $f.f2 $f.f2.1 {left expand fillx} \
                     $f.f2.2 {left expand fillx}
   pack append $f $f.f1 {top} \
                  $f.f2 {top fillx}
}

proc _loadit {c} {
   global gvar
   $c delete obj
   if {[file exists $gvar(oloadfile)]} {
      set fd [open $gvar(oloadfile) r]
      while {[gets $fd line] > -1} {
         regsub -all \033 $line \n line
         eval $line
      }
      close $fd
   } else {
      _mkdialog .dm {-text {INFO: could not access file} -aspect 500} \
         {{OK "destroy .dm"}}
      _load $c
   }
}

proc _load {c} {
   # gotta merge _save and _load into something like _getfile
   global gvar
   set f .loadframe
   catch {destroy $f}
   toplevel $f
   wm title $f "Load Options"
   frame $f.f1
      label $f.f1.1 -text "File Name" -width 10 
      entry $f.f1.2 -relief sunken -width 20 -textvariable gvar(oloadfile)
   pack append $f.f1 $f.f1.1 {left} \
                     $f.f1.2 {left}
   bind $f.f1.2 <Return> "destroy $f; _loadit $c"

   frame $f.f2
      button $f.f2.1 -bd 5 -text "APPLY"  -command "destroy $f; _loadit $c"
      button $f.f2.2 -bd 5 -text "CANCEL" -command "destroy $f"
   pack append $f.f2 $f.f2.1 {left expand fillx} \
                     $f.f2.2 {left expand fillx}
   pack append $f $f.f1 {top} \
                  $f.f2 {top fillx}
}

proc _drawbitmap {c} {
   global gvar font
   set fname [.i1.bitmap.2 get]
   if {[file exists $fname] && [regexp "c program text" [exec file $fname]]} {
      eval "$c create bitmap [lindex $gvar(coords) 0] [lindex $gvar(coords) 1] -anchor $gvar(bitmapanchor) -bitmap @$fname -tags \"obj\""
      $c delete trace
   }
}

proc _drawvfont {c} {
   global gvar font
   if {$gvar(coords)!=""} {
      set cx [lindex $gvar(coords) 0]
      set cy [lindex $gvar(coords) 1]
      set fname $gvar(vfontname)
      set txt [.i1.vfont.2 get]
      set ltxt [string length $txt]
      for {set i 0} {$i < $ltxt} {incr i} {
         scan [string index $txt $i] "%c" t3
         if {[info exists font($fname,$t3)]} {
            foreach j $font($fname,$t3) {
               eval "$c create $j -tags \"trace2 obj vtext\""
            }
            scan [$c bbox trace2] "%d %d %d %d" x1 y1 x2 y2
            set t4 [$c create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 \
               -tags "trace2 vtext$t3 obj" -fill ""]
            $c addtag vt$t4 withtag vtext
            $c dtag vtext
            puts stdout "$t4 [$c find withtag vt$t4]"
            set dx [expr $x2-$x1]
            $c move trace2 [expr $cx+($dx/2)] $cy
            incr cx $dx
            $c dtag trace2
         } else {
            incr cx 20
         }
      }
      set gvar(coords) ""
      $c delete trace
   }
}

proc _drawobj {c coords} {
   global gvar
   set gvar(pcoords) ""
   set x1 [lindex $coords 0]
   set y1 [lindex $coords 1]
   set t1 [llength $gvar(coords)]
   case $gvar(obj) in {
      {line} {
         case $t1 in {
            {0} {
               lappend gvar(coords) "$x1 $y1"
               $c create line $x1 $y1 $x1 $y1 -tags "trace" -width $gvar(width)
            }
            {1} {
               set t2 [lindex $gvar(coords) 0]
               set x2 [lindex $t2 0]
               set y2 [lindex $t2 1]
               eval "$c create line $x2 $y2 $x1 $y1 -tags \"obj\" \
                  -arrow $gvar(arrowloc) -capstyle $gvar(capstyle) \
                  -joinstyle $gvar(joinstyle) -width $gvar(width) \
                  -stipple $gvar(linepat) -arrowshape [list $gvar(arrowshape)]"
               set gvar(coords) {}
               $c delete trace
            }
         }
      }
      {oval} {
         case $t1 in {
            {0} {
               lappend gvar(coords) "$x1 $y1"
            }
            {1} {
               set t2 [lindex $gvar(coords) 0]
               set x2 [lindex $t2 0]
               set y2 [lindex $t2 1]
               eval $c create oval $x2 $y2 $x1 $y1 -tags \"obj\" -width $gvar(width) -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad -fill $gvar(fill)
               set gvar(coords) {}
               $c delete trace
            }
         }
      }
      {polyline} {
# area = (1/2)*ABS((x0+x1)*(y1-y0) + (x1+x2)*(y2-y1) + ... + (xn+x0)*(y0-yn))
         set l  [expr {$t1-1}]
         set t1 [lindex $gvar(coords) $l]
         set ox [lindex $t1 0]
         set oy [lindex $t1 1]
         puts stdout "$ox $x1   $oy $y1"
         if {$ox==$x1 && $oy==$y1} {
            set t2 ""
            foreach i $gvar(coords) {
               append t2 "$i "
            }
            if {$gvar(pat)==0} {
               eval "$c create line $t2 -tags \"obj\" \
                  -arrowshape [list $gvar(arrowshape)] -arrow $gvar(arrowloc) \
                  -joinstyle $gvar(joinstyle) -capstyle $gvar(capstyle) \
                  -stipple $gvar(linepat) -width $gvar(width)"
            } else {
               eval "$c create polygon $t2 -tags \"obj\" \
                  -fill $gvar(fill) \
                  -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad"
            }
            set gvar(coords) {}
            $c delete trace trace2 
         } else {
            $c addtag trace2 withtag trace
            $c dtag trace
            lappend gvar(coords) "$x1 $y1"
            $c create line $x1 $y1 $x1 $y1 -tags "trace"
         }
      }
      {polygon} {
         case $t1 in {
            {0} {
               lappend gvar(coords) "$x1 $y1"
               $c create line $x1 $y1 $x1 $y1 -tags "trace" -width $gvar(width)
            }
            {1} {
               set t2 [lindex $gvar(coords) 0]
               set cx [lindex $t2 0]
               set cy [lindex $t2 1]
               set a [expr 360.0/$gvar(pside)]
               set t3 "$x1 $y1 "
               for {set i 0} {$i < $gvar(pside)} {incr i} {
                  set t2 [_rot $a "$cx $cy" "$x1 $y1"]
                  set x1 [lindex $t2 0]
                  set y1 [lindex $t2 1]
                  append t3 "$x1 $y1 "
               }
               eval "$c create line $t3 -tags \"obj\" \
                 -arrow $gvar(arrowloc) -capstyle $gvar(capstyle) \
                 -joinstyle $gvar(joinstyle) -width $gvar(width) \
                 -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad \
                 -arrowshape [list $gvar(arrowshape)]"
               set gvar(coords) {}
               $c delete trace
            }
         }
      }
      {rect} {
         case $t1 in {
            {0} {
               lappend gvar(coords) "$x1 $y1"
#              $c create rectangle $x1 $y1 $x1 $y1 -tags "trace"
            }
            {1} {
               set t2 [lindex $gvar(coords) 0]
               set x2 [lindex $t2 0]
               set y2 [lindex $t2 1]
#              eval "$c create rectangle $x2 $y2 $x1 $y1 -tags \"obj\" \
#                 -width $gvar(width) -stipple @$gvar(HOME)/bitmaps/pat$gvar(pat).cad \
#                 -fill $gvar(fill)"
               set t2 "$x2 $y2 $x1 $y2 $x1 $y1 $x2 $y1 $x2 $y2"
               case $gvar(pat) in {
                  {0} {
                     eval "$c create line $t2 -tags \"obj\" \
                        -width $gvar(width) -stipple $gvar(linepat) \
                        -joinstyle $gvar(joinstyle) -capstyle $gvar(capstyle)"
                  }
                  default {
                     eval "$c create polygon $t2 -tags \"obj\" \
                        -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad -fill $gvar(fill)"
                  }
               }
               set gvar(coords) {}
               $c delete trace
            }
         }
      }
      {rrect} {
         case $t1 in {
            {0} {
               lappend gvar(coords) "$x1 $y1"
#              $c create rectangle $x1 $y1 $x1 $y1 -tags "trace"
            }
            {1} {
               set t2 [lindex $gvar(coords) 0]
               set x2 [lindex $t2 0]
               set y2 [lindex $t2 1]
               set t2 "$x2 $y2 "
               append t2 "[expr {($x1+$x2)/2.0}] $y2 "
               append t2 "$x1 $y2 "
               append t2 "$x1 [expr {($y2+$y1)/2.0}] "
               append t2 "$x1 $y1 "
               append t2 "[expr {($x1+$x2)/2.0}] $y1 "
               append t2 "$x2 $y1 "
               append t2 "$x2 [expr {($y2+$y1)/2.0}] "
               append t2 "$x2 $y2 "
               case $gvar(pat) in {
                  {0} {
                     eval "$c create line $t2 -tags \"obj\" -smooth 1 \
                        -width $gvar(width) -stipple $gvar(linepat) \
                        -joinstyle $gvar(joinstyle) -capstyle $gvar(capstyle)"
                  }
                  default {
                     eval "$c create polygon $t2 -tags \"obj\" -smooth 1 \
                        -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad -fill $gvar(fill)"
                  }
               }
               set gvar(coords) {}
               $c delete trace
            }
         }
      }
      {btext} {
         $c dtag text
         if {[$c type current]=="text"} {
            $c icursor current @$x1,$y1
            $c focus current
            $c select from current @$x1,$y1
            $c addtag text withtag current
         } else {
            $c delete trace
            $c create bitmap $x1 $y1 -bitmap @$gvar(HOME)/icon/xhair.icon -anchor center \
               -tags "trace"
            $c create text $x1 $y1 -tags "obj text" -justify $gvar(tfontjust) \
               -anchor $gvar(tfontanchor) -font $gvar(tfont)
            $c focus text
         }
      }
      {vtext} {
         set gvar(coords) "$x1 $y1"
         $c delete trace
         $c create bitmap $x1 $y1 -bitmap @$gvar(HOME)/icon/xhair.icon -anchor center \
            -tags "trace"
      }
      {bitmap} {
         set gvar(coords) "$x1 $y1"
         $c delete trace
         $c create bitmap $x1 $y1 -bitmap @$gvar(HOME)/icon/xhair.icon -anchor center \
            -tags "trace"
      }
      {arc} {
         case $t1 in {
            {0} {
               lappend gvar(coords) "$x1 $y1"
               $c create rectangle $x1 $y1 $x1 $y1 -tags "trace"
            }
            {1} {
               set t2 [lindex $gvar(coords) 0]
               set x2 [lindex $t2 0]
               set y2 [lindex $t2 1]
               lappend gvar(coords) "$x1 $y1"
               set cx [expr {($x1+$x2)/2.0}]
               set cy [expr {($y1+$y2)/2.0}]
               lappend gvar(coords) "$cx $cy"
               eval "$c create oval [$c coords trace] -tags \"trace2\""
               $c delete trace
               $c create line $cx $cy $cx $cy -tags "trace" -width $gvar(width)
               set gvar(tracemode) line
            }
            {3} {
               set x1 [lindex [$c coords trace] 2]
               set y1 [lindex [$c coords trace] 3]
               lappend gvar(coords) "$x1 $y1"
               eval "$c create line [$c coords trace] -tags \"trace2\""
               set gvar(tracemode) line
            }
            {4} {
               set x1 [lindex [$c coords trace] 2]
               set y1 [lindex [$c coords trace] 3]
               lappend gvar(coords) "$x1 $y1"
               # (x1,y1) (x2,y2) (cx,cy) (ax1,ay1) (ax2,ay2)
               set a1 [lindex $gvar(coords) 2]
               set cx [lindex $a1 0]
               set cy [lindex $a1 1]
               set a1 [lindex $gvar(coords) 3]
               set x1 [lindex $a1 0]
               set y1 [lindex $a1 1]
               set a1 [lindex $gvar(coords) 4]
               set x2 [lindex $a1 0]
               set y2 [lindex $a1 1]
#              puts stdout "$cx $cy $x1 $y1 $x2 $y2"
               set bx1 [lindex $gvar(coords) 0]
               set bx2 [lindex $gvar(coords) 1]
               set dx [expr [lindex $bx2 0]-[lindex $bx1 0]]
               set dy [expr [lindex $bx2 1]-[lindex $bx1 1]]
               set ecc [expr 1.0*$dx/$dy]
               set dx [expr $x1-$cx]
               set dy [expr $cy-$y1]
               set a1 [_getangle $dx [expr $dy*$ecc]]
               set dx [expr $x2-$cx]
               set dy [expr $cy-$y2]
               set a2 [_getangle $dx [expr $dy*$ecc]]
               set a2 [expr $a2-$a1]
               puts stdout "$a1 $a2"
               eval "$c create arc $bx1 $bx2 -start $a1 -extent $a2 -tags \"obj\" -style $gvar(oarcstyle) -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad -fill $gvar(fill)"
               set gvar(coords) {}
               $c delete trace trace2
            }
         } 
      }

   }
}

proc _boundingbox {c obj} {
   set t1 [$c bbox $obj]
   if {$t1==""} {
      $c delete trace
   } else {
      scan $t1 "%f %f %f %f" x1 y1 x2 y2
      set dx [expr ($x2-$x1)/4.0]
      set dy [expr ($y2-$y1)/4.0]
      set u1 [expr $x1+$dx]
      set u2 [expr $x2-$dx]
      set v1 [expr $y1+$dy]
      set v2 [expr $y2-$dy]
      $c create line $x1 $v1 $x1 $y1 $u1 $y1 -tags "trace nw"
      $c create line $u1 $y1 $u2 $y1 -tags "trace n"
      $c create line $u2 $y1 $x2 $y1 $x2 $v1 -tags "trace ne"
      $c create line $x2 $v1 $x2 $v2 -tags "trace e"
      $c create line $x2 $v2 $x2 $y2 $u2 $y2 -tags "trace se"
      $c create line $u2 $y2 $u1 $y2 -tags "trace s"
      $c create line $u1 $y2 $x1 $y2 $x1 $v2 -tags "trace sw"
      $c create line $x1 $v2 $x1 $v1 -tags "trace w"
   }
}

proc _pickscan {c x2 y2} {
   global gvar
   set x1 [lindex $gvar(pcoords) 0]
   set y1 [lindex $gvar(pcoords) 1]
   set x2 [$c canvasx $x2]
   set y2 [$c canvasy $y2]
   $c delete trace
   $c create rectangle $x1 $y1 $x2 $y2 -tags "trace"
   set gvar(pcoords) "$x1 $y1 $x2 $y2"
}

proc _pickobj {c t2} {
   global gvar
   
   set result 0
   
   foreach i $t2 {
      set po [$c gettags $i]
      if {[lsearch $po X] > -1} { 
         return -1
      } elseif {[lsearch $po trace] > -1} {
         return -1
      } elseif {[lsearch $po cgrp*] > -1} {
         set t1 [lindex $po [lsearch $po cgrp*]]
         $c addtag pick withtag $t1
         $c addtag pick withtag grp[$c find withtag $t1]
         _boundingbox $c pick
         return 1
      } elseif {[lsearch $po vtext*] > -1} {
         if {$i=="current"} {
            set t3 [$c find withtag $i]
            $c addtag pick withtag vt$t3
            $c addtag pick withtag $t3
#           scan [$c bbox $i] "%d %d %d %d" x1 y1 x2 y2
#           $c addtag pick enclosed $x1 $y1 $x2 $y2
            _boundingbox $c $t3
            return 1
         } else {
            $c addtag pick withtag $i
            $c delete trace
            _boundingbox $c pick
            incr result
         }
      } elseif {[lsearch $po pick] > -1} {
#        puts stdout "UNPICK"
         $c dtag $i pick
         $c delete trace
         _boundingbox $c pick
         return 0
      } else {
#        puts stdout "PICK"
         $c addtag pick withtag $i
         _boundingbox $c $i
         incr result
      }
   }
   return $result
}

proc _pickarea {c} {
   global gvar
   if {[llength $gvar(pcoords)]<3} {
      set gvar(onopick) [_pickobj $c current]
      if {$gvar(onopick)<1} { 
         $c dtag pick pick
         $c delete trace trace2
      }
   } else {
      set t1 [$c coords trace]
      if {$t1!=""} {
         scan $t1 "%f %f %f %f" x1 y1 x2 y2
         set t2 [$c find enclosed $x1 $y1 $x2 $y2]
         $c delete trace trace2
         if {$t2!=""} {
            set gvar(onopick) [_pickobj $c "$t2"]
         }
         set gvar(pcoords) ""
      }
   }
}

proc _moveobj {c dx dy} {
   global gvar
   $c move pick $dx $dy
   $c move trace $dx $dy
}

proc _deleteobj {c} {
   $c delete pick
   $c delete trace
}

proc _group {c} {
   set t1 [$c bbox pick]
   if {$t1!=""} {
      scan $t1 "%f %f %f %f" x1 y1 x2 y2
      set t2 [$c create rectangle $x1 $y1 $x2 $y2 -tags "pick" -outline ""]
      $c addtag cgrp$t2 withtag $t2
      foreach i [$c find withtag pick] {
         $c addtag grp$t2 withtag $i
         puts stdout "...adding grp$t2 to $i"
      }
      $c delete trace
      _boundingbox $c grp$t2
   }
}

proc _ungroup {c} {
   $c delete trace trace2
   set t1 ""
   foreach i [$c gettags pick] {
      set t1 "$i $t1" 
   }
   puts stdout "Ungroup: $t1"
   foreach i $t1 {
      case $i in {
         {grp*} {
            $c dtag c$i $i
            set t2 [$c find withtag $i]
            foreach j $t2 {
               _boundingbox $c $j
            }
            $c delete c$i
            $c dtag $i
         }
      }
   }
}

proc _front {c} {
   set t1 [$c find above pick]
   set t2 [$c gettags $t1]
   if {$t2=="obj"} {
      $c raise pick $t1
   }
}

proc _back {c} {
   set t1 [$c find below pick]
   set t2 [$c gettags $t1]
   if {$t2=="obj"} {
      $c lower pick $t1  
   }
}

proc _flip {c sx sy} {
   set t2 [$c find withtag pick]
   scan [$c bbox pick] "%f %f %f %f" x1 y1 x2 y2
   set cx [expr {($x1+$x2)/2.0}]
   set cy [expr {($y1+$y2)/2.0}]
   foreach i $t2 {
      $c move $i [expr {-1*$cx}] [expr {-1*$cy}]
      set t1 [$c coords $i]
      set k 0
      set result {}
      foreach j $t1 {
         if {[expr {$k%2}]==0} {
            append result "[expr {$sx*$j}] "
         } else {
            append result "[expr {$sy*$j}] "
         }
         incr k
      }
      eval "$c coords $i $result"
      $c move $i $cx $cy
   }
}

proc _smooth {c {yon no}} {
   set t1 [$c find withtag pick]
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
      {line polygon} {$c itemconfig $i -smooth $yon}
      }
   }
}

proc _setbitmap {c tag} {
   global gvar
   set t1 [$c find withtag $tag]
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
         {bitmap} {
            eval $c itemconfig $i -anchor $gvar(bitmapanchor)
         }
      }
   }
}

proc _setpattern {c} {
   global gvar
   foreach i {0 1 2 3 4 5 6 7 8} {
      .p.$i configure -bitmap @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$i.cad
   }
}

proc _setarcstyle {c} {
   global gvar
   set t1 [$c find withtag pick]
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
         {arc} {
            eval $c itemconfig $i -style $gvar(oarcstyle)
         }
      }
   }
}
   
proc _setfill {c p tag} {
   global gvar
   .p.10 configure -bitmap @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$p.cad
   case $p in {
      {0} {
         set gvar(pat) $p
         set gvar(fill) \"\"
      }
      {8} {
         set gvar(pat) 7
         set gvar(fill) white
      }
      default {
         set gvar(pat) $p
         set gvar(fill) black
      }
   }
   set t1 [$c find withtag $tag]
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
         {line arc oval} {
            eval $c itemconfig $i -fill $gvar(fill) -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad
         }
         {polygon} {
            if {[lsearch [$c gettags $i] vtext*] < 0} {
               eval $c itemconfig $i -fill $gvar(fill) -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad
            }
         }
         {rectangle} {
            if {[lsearch [$c gettags $i] cgrp*] < 0} {
               eval $c itemconfig $i -fill $gvar(fill) -stipple @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad
            }
         }
      }
   }
}

proc _setrotate {c tag} {
   global gvar
   set ra [string trim $gvar(orotate)]
   if {![regexp {^(-?[0-9]+)$} $ra]} {
      return
   }
   scan [$c bbox $tag] "%f %f %f %f" x1 y1 x2 y2
   set cx [expr {($x2+$x1)/2.0}]
   set cy [expr {($y2+$y1)/2.0}]
   set t1 [$c find withtag $tag]
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
         {oval line rectangle polygon} {
            set t3 ""
            set coord [$c coords $i]
            for {set k 0} {$k < [llength $coord]} {incr k 2} {
               set x1 [lindex $coord $k]
               set y1 [lindex $coord [expr $k+1]]
               append t3 [_rot $ra "$cx $cy" "$x1 $y1"] " "
            }
            eval "$c coords $i $t3"
         }
      }
   }
   $c delete trace
   _boundingbox $c $tag
}

proc _setwidth {c tag value} {
   global gvar
   set t1 [$c find withtag $tag]
   set gvar(width) $value
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
         {arc oval rectangle line} {$c itemconfig $i -width $value}
      }
   }
}

proc _setfont {c tag} {
   global gvar
   set t1 [$c find withtag $tag]
   set gvar(tfont) "-*-$gvar(tfontname)-$gvar(tfontweight)-$gvar(tfontslant)-normal--*-[expr {10*$gvar(tfontpoint)}]-*"
   foreach i $t1 {
      set t2 [$c type $i]
      case $t2 in {
         {text} {$c itemconfig $i -font $gvar(tfont) -just $gvar(tfontjust) \
                    -anchor $gvar(tfontanchor)
                 $c delete trace
                 _boundingbox $c $tag
         }
      }
   }
}

proc _loadvfont {} {
   global gvar font
   set fname $gvar(vfontname)
   if {[file exist $gvar(HOME)/vfont/$fname.tkfont]} {
      set fd [open $gvar(HOME)/vfont/$fname.tkfont r]
      while {[gets $fd line] > -1} {
         set t1 [lindex $line 0]
         set font($fname,$t1) [lrange $line 2 end]
      }
      close $fd
   }
}

proc _setvfont {c tag} {
   global gvar
   _loadvfont
}

proc _arrowloc {c tag value} {
   global gvar
   set t1 [$c find withtag $tag]
   set gvar(arrowloc) $value
   if {$t1!=""} {
      foreach i $t1 {
         set t2 [$c type $i]
         case $t2 in {
            {line} {$c itemconfig $i -arrow $gvar(arrowloc)}
         }
      }
   }
}

proc _setarrow {c type value} {
   global gvar
   case $type in {
      {ah} {
         set gvar(temp) "[lindex $gvar(temp) 0] [lindex $gvar(temp) 1] $value"
         $c itemconfig test -arrowshape $gvar(temp)
      }
      {bw} {
         set gvar(temp) "$value [lindex $gvar(temp) 1] [lindex $gvar(temp) 2]"
         $c itemconfig test -arrowshape $gvar(temp)
      }
      {aw} {
         set gvar(temp) "[lindex $gvar(temp) 0] $value [lindex $gvar(temp) 2]"
         $c itemconfig test -arrowshape $gvar(temp)
      }
   }
}

proc _keepvalue {w x} {
   global gvar
   set $x $gvar(temp)
   .w.1 set $gvar(width)
   destroy $w
}

proc _arrowshape {w} {
   global gvar
   catch {destroy $w}
   toplevel $w
   set gvar(temp) $gvar(arrowshape)
   frame $w.c
      canvas $w.c.2 -h 150 -relief raised -bd 3
      foreach i {{0 50 100 50} {50 0 50 100} {150 0 250 100} {150 100 250 0}} {
         eval "$w.c.2 create line $i -arrow both -tags \"test\" \
            -arrowshape [list $gvar(arrowshape)] -width $gvar(width)"
      }
      $w.c.2 move test 25 25
   pack append $w.c $w.c.2 {top}
   
   frame $w.s
      set j 1
      foreach i {lineWidth arrowHeight arrowWidth baseWidth} {
         scale $w.s.$j -label $i -length 100 -width 10 -from 1 -to 30 \
            -orient horiz
         pack append $w.s $w.s.$j {left padx 5}
         incr j
      }
      $w.s.1 set $gvar(width)
      $w.s.2 set [lindex $gvar(arrowshape) 2]
      $w.s.3 set [lindex $gvar(arrowshape) 1]
      $w.s.4 set [lindex $gvar(arrowshape) 0]
      $w.s.1 configure -command "_setwidth $w.c.2 test"
      $w.s.2 configure -command "_setarrow $w.c.2 ah"
      $w.s.3 configure -command "_setarrow $w.c.2 aw"
      $w.s.4 configure -command "_setarrow $w.c.2 bw"

   frame $w.b
      button $w.b.1 -text "DONE" -bd 5 -command "_keepvalue $w gvar(arrowshape)"
      button $w.b.2 -text "CANCEL" -bd 5 -command "destroy $w"
   pack append $w.b $w.b.1 {left expand fillx} \
                    $w.b.2 {left expand fillx}

   pack append $w $w.c {top expand fill} \
                  $w.s {top fill} \
                  $w.b {top expand fillx}
}

proc _capstyle {w} {
   global gvar
   set gvar(temp) $gvar(capstyle)
   catch {destroy $w}
   toplevel $w
   frame $w.c
      canvas $w.c.2 -h 150 -relief raised -bd 3
      foreach i {{0 50 100 50} {50 0 50 100} {150 0 250 100} {150 100 250 0}} {
         eval "$w.c.2 create line $i -tags test -capstyle $gvar(temp) -width $gvar(width)"
      }
      $w.c.2 move test 25 25
   pack append $w.c $w.c.2 {top}
   
   frame $w.s
      scale $w.s.1 -label "lineWidth" -length 100 -width 10 -from 1 -to 30 \
         -orient horiz
      pack append $w.s $w.s.1 {left padx 5}
      $w.s.1 set $gvar(width)
      $w.s.1 configure -command "_setwidth $w.c.2 test"
      set j 2
      foreach i {butt projecting round} {
         radiobutton $w.s.$j -text $i -variable gvar(temp) -value $i \
            -command "$w.c.2 itemconfig test -capstyle $i"
         pack append $w.s $w.s.$j {left padx 5}
         incr j
      }

   frame $w.b
      button $w.b.1 -text "DONE" -bd 5 -command "_keepvalue $w gvar(capstyle)"
      button $w.b.2 -text "CANCEL" -bd 5 -command "destroy $w"
   pack append $w.b $w.b.1 {left expand fillx} \
                    $w.b.2 {left expand fillx}

   pack append $w $w.c {top expand fill} \
                  $w.s {top fill} \
                  $w.b {top expand fillx}
}

proc _joinstyle {w} {
   global gvar
   catch {destroy $w}
   set gvar(temp) $gvar(joinstyle)
   toplevel $w
   frame $w.c
      canvas $w.c.2 -h 150 -relief raised -bd 3
      foreach i {{0 0 0 100 100 100} {125 0 175 100 225 0 275 100}} {
         eval "$w.c.2 create line $i -tags test -joinstyle $gvar(temp) -width $gvar(width)"
      }
      $w.c.2 move test 25 25
   pack append $w.c $w.c.2 {top}
   
   frame $w.s
      scale $w.s.1 -label "lineWidth" -length 100 -width 10 -from 1 -to 30 \
         -orient horiz
      pack append $w.s $w.s.1 {left padx 5}
      $w.s.1 set $gvar(width)
      $w.s.1 configure -command "_setwidth $w.c.2 test"
      set j 2
      foreach i {miter bevel round} {
         radiobutton $w.s.$j -text $i -variable gvar(temp) -value $i \
            -command "$w.c.2 itemconfig test -joinstyle $i"
         pack append $w.s $w.s.$j {left padx 5}
         incr j
      }

   frame $w.b
      button $w.b.1 -text "DONE" -bd 5 -command "_keepvalue $w gvar(joinstyle)"
      button $w.b.2 -text "CANCEL" -bd 5 -command "destroy $w"
   pack append $w.b $w.b.1 {left expand fillx} \
                    $w.b.2 {left expand fillx}

   pack append $w $w.c {top expand fill} \
                  $w.s {top fill} \
                  $w.b {top expand fillx}
}

proc _setscale {c dir} {
   global gvar
   set t1 [$c bbox pick]
   if {$t1!=""} {
      scan $t1 "%f %f %f %f" x1 y1 x2 y2
      set cx [expr {($x2+$x1)/2.0}]
      set cy [expr {($y2+$y1)/2.0}]
      set t2 [.s.$dir get]
      if {![regexp {^((0?\.?[1-9][0-9]*)|([0-9]+\.[0-9]+))$} $t2]} { return }
      set t3 [expr {1.0/$gvar(oscale)}]
      case $dir in {
      {1} {set t4 "$t3 $t3"
           set t5 "$t2 $t2"
          }
      {2} {set t4 "$t3 1.0"
           set t5 "$t2 1.0"
          }
      {3} {set t4 "1.0 $t3"
           set t5 "1.0 $t2"
          }
      }
      if {$gvar(oscaletype)=="abs"} {
         eval "$c scale pick $cx $cy $t4"
      }
      eval "$c scale pick $cx $cy $t5"
      set gvar(oscale) $t2
      $c delete trace
      _boundingbox $c pick
   }
}

proc _printit {c} {
   global gvar
   $c coords xhair 0 0 0 0
   $c coords yhair 0 0 0 0
   $c delete trace trace2
   $c dtag pick
   _canvasprint $c
}

wm minsize . 100 100

frame .m -bd 2 -relief sunken
   menubutton .m.file -text "File" -menu .m.file.m
   menu .m.file.m
      .m.file.m add command -label "Clear" -command ".c.c delete obj"
      .m.file.m add command -label "Print" -command "_printit .c.c"
      .m.file.m add command -label "Dump"  -command "_dumpobj .c.c obj stdout"
      .m.file.m add command -label "Save"  -command "_save .c.c"
      .m.file.m add command -label "Load"  -command "_load .c.c"
      .m.file.m add command -label "Quit"  -command "destroy ."
   menubutton .m.bfont -text "BFont" -menu .m.bfont.m
   menu .m.bfont.m
      set font(name)   {courier helvetica times symbol {new century schoolbook}}
      set font(weight) {medium bold}
      set font(slant)  {r o i}
      set font(point)  {8 10 12 14 18 24}
      set font(just)   {left center right}
      set font(anchor) {nw n ne w c e sw s se}
      foreach i {name weight slant point just anchor} {
         .m.bfont.m add cascade -label $i -menu .m.bfont.m.$i
         menu .m.bfont.m.$i
         foreach j $font($i) {
            .m.bfont.m.$i add radio -label $j -variable gvar(tfont$i) \
               -value $j -command "_setfont .c.c pick"
         }
      }
   menubutton .m.vfont -text "VFont" -menu .m.vfont.m
   menu .m.vfont.m
      set vfont(name) ""
      foreach i [glob $gvar(HOME)/vfont/*.tkfont] {
         append vfont(name) "[file tail [file root $i]] "
      }
      foreach i {name} {
         .m.vfont.m add cascade -label $i -menu .m.vfont.m.$i
         menu .m.vfont.m.$i
         foreach j $vfont($i) {
            .m.vfont.m.$i add radio -label $j -variable gvar(vfont$i) \
               -value $j -command "_setvfont .c.c pick"
         }
      }
   menubutton .m.misc -text "Misc" -menu .m.misc.m
   menu .m.misc.m
      .m.misc.m add cascade -label "Scale" -menu .m.misc.m.scale
      menu .m.misc.m.scale
         .m.misc.m.scale add radio -label "Absolute" \
            -variable gvar(oscaletype) -value abs
         .m.misc.m.scale add radio -label "Relative" \
            -variable gvar(oscaletype) -value rel
      .m.misc.m add cascade -label "Snap" -menu .m.misc.m.snap
      menu .m.misc.m.snap
         foreach i {normal grid gravity} {
            .m.misc.m.snap add radio -label $i -variable gvar(osnap) -value $i
         }
      .m.misc.m add cascade -label "Pattern" -menu .m.misc.m.pat
      menu .m.misc.m.pat
      foreach i [glob $gvar(HOME)/bitmaps/*] {
         set j [file tail [file root $i]]
         .m.misc.m.pat add radio -label $j -variable gvar(opattern) \
               -value $j -command "_setpattern .c.c"
      }
      .m.misc.m add cascade -label "ArcStyle" -menu .m.misc.m.arc
      menu .m.misc.m.arc
      foreach i {arc pieslice chord} {
         .m.misc.m.arc add radio -label $i -variable gvar(oarcstyle) \
               -value $i -command "_setarcstyle .c.c"
      }
      .m.misc.m add cascade -label "Bitmap" -menu .m.misc.m.bitmap
      menu .m.misc.m.bitmap
      foreach i {nw n ne w c e sw s se} {
         .m.misc.m.bitmap add radio -label $i -variable gvar(bitmapanchor) \
               -value $i -command "_setbitmap .c.c pick"
      }
      
   label .m.nopickl -text "Obj picked="
   label .m.nopick -textvariable gvar(onopick)
   label .m.nocutl -text "Cut bufsize="
   label .m.nocut  -textvariable gvar(onocut)
   label .m.obj    -textvariable gvar(obj)
   label .m.coords -textvariable gvar(xylabel)
pack append .m .m.file      {left fillx} \
               .m.bfont     {left fillx} \
               .m.vfont     {left fillx} \
               .m.misc      {left fillx} \
               .m.coords    {right} \
               .m.obj       {right} \
               .m.nocut     {right} \
               .m.nocutl    {right} \
               .m.nopick    {right} \
               .m.nopickl   {right}
   
frame .o
   set j 1
   foreach i {line oval rect rrect polyline polygon btext vtext arc bitmap guide morph} {
      case $i in {
      {line polyline polygon} {set k line}
      {oval rect rrect arc}   {set k rect}
      default                 {set k point}
      }
      button .o.$i -bitmap @$gvar(HOME)/icon/$i.cad -bd 5 -command "set gvar(obj) $i; set gvar(tracemode) $k; _restore .c.c"
      pack append .o .o.$i {top}
      incr j
   }
   .o.morph configure -state disabled
   .o.guide configure -state disabled

frame .cmd
   set j 1
   foreach i {move front back smooth unsmooth group ungroup flipx flipy copy paste cut} {
      button .cmd.$i -bitmap @$gvar(HOME)/icon/$i.cad -bd 5
      pack append .cmd .cmd.$i {top}
      incr j
   }
   .cmd.move     configure -command {set gvar(obj) cursor; set coords {}}
   .cmd.front    configure -command { _front .c.c }
   .cmd.back     configure -command { _back .c.c }
   .cmd.smooth   configure -command { _smooth .c.c yes}
   .cmd.unsmooth configure -command { _smooth .c.c no}
   .cmd.group    configure -command { _group .c.c }
   .cmd.ungroup  configure -command { _ungroup .c.c }
   .cmd.flipx    configure -command { _flip .c.c -1.0 1.0 }
   .cmd.flipy    configure -command { _flip .c.c 1.0 -1.0 }
   .cmd.copy     configure -command { _cutobj .c.c }
   .cmd.paste    configure -command { _pasteobj .c.c "10 10"}
   .cmd.cut      configure -command { _deleteobj .c.c }

frame .c -relief raised -bd 3
   canvas .c.c -scrollregion "-1000 -1000 1000 1000" -w 300 -h 300 \
      -xscroll ".c.hs set" -yscroll ".c.vs set"
   scrollbar .c.vs -relief sunken -command ".c.c yview"
   scrollbar .c.hs -orient horiz -relief sunken -command ".c.c xview"
pack append .c .c.hs {bottom fillx} \
               .c.vs {right filly} \
               .c.c  {expand fill}

frame .p -bd 2 -relief sunken
   label  .p.10 -bitmap @$gvar(HOME)/bitmaps/$gvar(opattern)/pat$gvar(pat).cad -relief raised -bd 5
   pack append .p .p.10 {left}
   foreach i {0 1 2 3 4 5 6 7 8} {
      button .p.$i -relief sunken -bd 1 -width 16 -height 16 \
         -command "_setfill .c.c $i pick"
      pack append .p .p.$i {left padx 5 pady 5}
   }
   _setpattern .c.c

frame .w 
   scale  .w.1 -label "Width" -length 100 -width 10 -from 1 -to 30 \
      -orient horiz -command "_setwidth .c.c pick"
   pack append .w .w.1 {left}
   set j 2
   foreach i {none first last both} {
      radiobutton .w.$j -bitmap @$gvar(HOME)/icon/${i}arrow.cad -variable arrowtype \
         -value $i -command "_arrowloc .c.c pick $i"
      pack append .w .w.$j {left}
      incr j
   }
   set j 6
   foreach i {arrowshape capstyle joinstyle} {
      button .w.$j -text $i -bd 5 -command "_$i .$i"
      pack append .w .w.$j {left}
      incr j
   }

frame .i1
   frame .i1.bfont
      label  .i1.bfont.1 -text "BFont" -relief flat -width 5
      entry  .i1.bfont.2 -width 20 -relief sunken -textvariable gvar(tfont)
      bind   .i1.bfont.2 <Return> "_setfont .c.c pick"
   pack append .i1.bfont .i1.bfont.1 {left} \
                         .i1.bfont.2 {left}
   frame .i1.vfont
      label  .i1.vfont.1 -text "VFont" -relief flat -width 5
      entry  .i1.vfont.2 -width 20 -relief sunken -textvariable gvar(vftext)
      bind   .i1.vfont.2 <Return> "_drawvfont .c.c"
   pack append .i1.vfont .i1.vfont.1 {left} \
                         .i1.vfont.2 {left fillx}
   frame .i1.bitmap
     label .i1.bitmap.1 -text "Bitmap" -relief flat -width 5
     entry .i1.bitmap.2 -width 20 -relief sunken -textvariable gvar(obitmap)
     bind  .i1.bitmap.2 <Return> "_drawbitmap .c.c"
   pack append .i1.bitmap .i1.bitmap.1 {left} \
                          .i1.bitmap.2 {left fillx}
pack append .i1 .i1.bfont  {left fillx} \
                .i1.vfont  {left fillx} \
                .i1.bitmap {left fillx}

frame .s
   label .s.1l -text "Scale" -relief flat
   entry .s.1 -width 5 -relief sunken -bd 3
   label .s.2l -text "SX" -relief flat
   entry .s.2 -width 5 -relief sunken -bd 3
   label .s.3l -text "SY" -relief flat
   entry .s.3 -width 5 -relief sunken -bd 3
   label .s.4l -text "Rotate" -relief flat
   entry .s.4 -width 5 -relief sunken -bd 3 -textvariable gvar(orotate)
   label .s.5l -text "GridX" -relief flat
   entry .s.5 -width 5 -relief sunken -bd 3 -textvariable gvar(gridx)
   label .s.6l -text "GridY" -relief flat
   entry .s.6 -width 5 -relief sunken -bd 3 -textvariable gvar(gridy)
   label .s.7l -text "Psides" -relief flat
   entry .s.7 -width 5 -relief sunken -bd 3 -textvariable gvar(pside)
   bind .s.1 <Return> "_setscale .c.c 1"
   bind .s.2 <Return> "_setscale .c.c 2"
   bind .s.3 <Return> "_setscale .c.c 3"
   bind .s.4 <Return> "_setrotate .c.c pick"
pack append .s .s.1l {left} \
               .s.1  {left} \
               .s.2l {left} \
               .s.2  {left} \
               .s.3l {left} \
               .s.3  {left} \
               .s.4l {left} \
               .s.4  {left} \
               .s.5l {left} \
               .s.5  {left} \
               .s.6l {left} \
               .s.6  {left} \
               .s.7l {left} \
               .s.7  {left}

pack append . .m      {top fillx} \
              .s      {bottom fillx} \
              .p      {bottom fillx} \
              .w      {bottom fillx} \
              .i1     {bottom fillx} \
              .o      {left filly} \
              .cmd    {left filly} \
              .c      {right expand fill}

.c.c create line -1000 2 1000 2 -tags "xhair X"
.c.c create line 2 -1000 2 1000 -tags "yhair X"

bind .c.c <Enter>       {focus %W}
bind .c.c <Motion>      { _drawcursor .c.c "%x %y" }
bind .c.c <Button-1>    { _drawobj .c.c "$gvar(cx) $gvar(cy)" }
bind .c.c <Button-2>    { set gvar(pcoords) "[.c.c canvasx %x] [.c.c canvasy %y]"; set gvar(coords) ""; .c.c focus "" }
bind .c.c <B2-Motion>   { _pickscan .c.c %x %y }
bind .c.c <ButtonRelease-2> { _pickarea .c.c }
bind .c.c <Shift-Up>    { _moveobj .c.c 0 -1 }
bind .c.c <Up>          { _moveobj .c.c 0 -10 }
bind .c.c <Shift-Down>  { _moveobj .c.c 0 1 }
bind .c.c <Down>        { _moveobj .c.c 0 10 }
bind .c.c <Shift-Right> { _moveobj .c.c 1 0 }
bind .c.c <Right>       { _moveobj .c.c 10 0 }
bind .c.c <Shift-Left>  { _moveobj .c.c -1 0 }
bind .c.c <Left>        { _moveobj .c.c -10 0 }
# bind .c.c <BackSpace>   { _deleteobj .c.c }
bind .c.c <Delete>      { _deleteobj .c.c }

foreach i {n e s w ne nw se sw} {
   .c.c bind $i <Enter>           ".c.c itemconfig $i -width 5"
   .c.c bind $i <Leave>           ".c.c itemconfig $i -width 1"
   .c.c bind $i <B2-Motion>       {puts stdout "Nstart"}
   .c.c bind $i <ButtonRelease-2> {puts stdout "Nend"}
}

proc _btextdelete {w} {
   set t1 ""
   set t2 [catch {$w index text sel.first} t1]
   if {[string range $t1 0 8] != "selection"} {
      $w dchars text sel.first sel.last
   } else {
      set x [expr {[$w index text insert] - 1}]
       if {$x >= 0} {$w dchars text $x}
   }
}

proc _btextmove {w i} {
   set x [expr {[$w index text insert] + $i}]
   set xm [$w index text end]
   if {$x >= 0 && $x <= $xm} {$w icursor text $x}
}

.c.c bind text <KeyPress>       { .c.c insert text insert %A }
.c.c bind text <Shift-KeyPress> { .c.c insert text insert %A }
.c.c bind text <Shift-1>        { .c.c select adjust current @%x,%y }
.c.c bind text <Return>         { .c.c insert text insert \n }
.c.c bind text <Control-h>      { _btextdelete .c.c }
.c.c bind text <Delete>         { _btextdelete .c.c }
.c.c bind text <BackSpace>      { _btextdelete .c.c }
.c.c bind text <Control-u>      { .c.c dchars text 0 end }
.c.c bind text <Left>           { _btextmove .c.c -1 }
.c.c bind text <Right>          { _btextmove .c.c 1 }
.c.c bind text <Button1-Motion> { .c.c select to text @%x,%y }
.c.c bind text <ButtonPress-2>  { catch {%W insert text insert [selection get]} }

if {$argv!=""} {
   set gvar(oloadfile) $argv
   set gvar(osavefile) $argv
} else {
   set gvar(oloadfile) $gvar(HOME)/init.tkobj
}
_loadit .c.c
