proc allspaces { {s }  } {
   foreach i [split $s {}] {      
       if {$i != " "} {return 0 } ;      
    } ;      
    return 1      
}

proc array2list { {na  {cname}} {va  {ccontent}} {names  {cvars}}  } {
   upvar  #0 $na n  $va v
   set list {}
   if {$names == {}} { set nam [array names n] } {
      upvar #0 $names nam
   }
   foreach i $nam {
      set l {}
      lappend l $n($i)
      if {[info exists v($i)] == 1} {lappend l $v($i); };
      if {"$i" != "$n($i)"} { lappend l $i };
      lappend list $l
   }
   return $list
}


proc block_del { {n }  } {
    global mc;
    foreach i [$mc find withtag $n] {
       if {[lindex [ $mc itemcget $i -tag ] 0] == $n}  {$mc del $i}
    }
}

proc block_get_pinnames { {block } {pintype  {}}  } {
    global mc;
    set o {};
    foreach i [eval "tag_and {$block pin $pintype}"] {
       lappend o [lindex [$mc itemcget $i -tags] 3]
    };
    return $o
}

proc block_name_fromid { {id }  } {
    global mc
    eval return [lindex [$mc itemcget $id -tags] 0]
}

proc blockbinds {  } {
    global mc
    $mc bind all <ButtonPress-1> {  global hx hy hl mc; set hx %X; set hy %Y;  set hl [lindex [$mc gettags current] 0];  bind $mc <Motion> {  global hx hy hl mc;  foreach i [$mc find withtag "$hl"] {  if {[lindex [$mc itemcget $i -tags] 0 ] == "$hl"}  {$mc move  $i  [expr %%X-$hx] [expr %%Y-$hy]}  };  wire_update $hl ; set hx %%X; set hy %%Y;  }  } ;
    bind $mc <ButtonRelease-1> {global mc; bind $mc <Motion> {}} ;
    $mc bind block <Double-ButtonPress-1> {   if { [llength  [listunion  [$mc find withtag  [lindex [$mc itemcget current -tags] 0]  ] [  $mc find withtag bbox  ]  ]  ] == 0  }  { cbbox [lindex [$mc itemcget current -tags] 0] selection0}  { eval $mc del  [listunion [$mc find withtag bbox]  [$mc find withtag [lindex [$mc itemcget current -tags] 0] ]]} ;  }
    $mc bind pin <ButtonPress-1> {
       togglepinsel current
    }
    $mc bind wire <ButtonPress-1> {
       togglepinsel [tag_and [ concat [lrange   [$mc itemcget current -tags] 3 4]  pin]];
       togglepinsel [tag_and [ concat [lrange   [$mc itemcget current -tags] 5 6]  pin]] }
    $mc bind  drumbol <ButtonPress-1> {
       global mc;
       if {[$mc itemcget current -outline] == {}}  {$mc itemco current -outline purple -width 2}   {$mc itemco current -outline {}}
       }
}

proc blockclear { {blocks }  } {
   foreach block $blocks {
      set v [blockfunc $block init];
      global $v ; set $v {}
      set v [blockfunc $block];
      global $v ; set $v {}
      foreach pin [block_get_pinnames $block] {
	 set p [pinvar $block $pin]
	 global $p
	 set $p {}
      }
   }
}

proc blockfunc { {block } {type  {}}  } {
   set o {}
   if {$type != {} } {set type _$type};
   append o  $block . bfunc $type ;
   return $o
}

proc bvar { {block } {var } {val  {}}  } {
   set v \{$block.$var\}
   #puts $v
   #puts $vv
      if {$val == {}} {
	 eval upvar #0 $v vv
	 return $vv
      } {
	 uplevel #0 set $v $val
      }
}

proc bwise { {rmw  {mw}}  } {
   uplevel #0 {if {![info exists mw]} {set mw {}} 
   set bcount 0
   set scopeindex 0
   set wireindex 0
   set shellindex 0
   set drumindex 0 
   set ident 0
 }
   global mw mc
   set mc $mw.c 
 
  


############################ MAIN CODE  ################################# 
  
   mainbuttons $mw
   main_window $mw Main 
   blockbinds
   canmenu
 
   history keep 1000 
}

proc canbwin { {b }  } {
   global tt
   set bn {} ; append bn ".$b" "info" ; set bn [string tolower $bn]
   catch "destroy $bn"
   toplevel $bn
   set bs $b*
   uplevel #0 "eval {set tt \[info var $bs\]} "
   set j 0
   foreach i [lsort -dict $tt]  {
      set il [string tolower $i]
      frame $bn.n$j ; pack $bn.n$j -side top -expand n -fill x
      label $bn.n$j.l -text $i -width 8 -anchor e
      pack $bn.n$j.l -side left -expand n -fill x
      entry $bn.n$j.e -textvar $i
      pack $bn.n$j.e -side left -expand y -fill x
      incr j
   }
    frame $bn.n$j ; pack $bn.n$j -side bottom -expand n -fill none
    button $bn.n$j.c -text Close -command "destroy $bn"
    pack $bn.n$j.c -side left  -expand n -fill none
    button $bn.n$j.e -text Eval -command "uplevel #0 eval \$\{[blockfunc $b]\}"
    pack $bn.n$j.e -side left  -expand n -fill none
    incr j
}

proc canmenu {  } { 
   global mc 
   catch "destroy $mc.pm" 
   menu $mc.pm -tearoff 0 
   $mc.pm insert 1 command  -label {none} -state disabled 
   $mc.pm insert 2 command -label "Eval" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ; uplevel #0 eval $\{[blockfunc $t]\}  } 
   $mc.pm insert 3 command -label "Data" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ; canbwin $t } 
   $mc.pm insert 4 command -label "Propagate" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ; run $t} 
   $mc.pm insert 5 command -label "Transfer" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ; transfer $t} 
   $mc.pm insert 6 command -label "Run" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ;uplevel #0 eval $\{[blockfunc $t]\}; run $t} 

#   $mc.pm insert 5 command -label "Info" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ; set infoline "$t [block_get_pinnames $t]"; eval set befunc "\${$t.bfunc}" } 
   $mc bind all <Button-2> {global mc; $mc.pm entryco 0 -label [block_name_fromid current]; tk_popup $mc.pm [expr %X-0] %Y 1} 
}

proc cbbox { {name  {all}} {selection  {selection0}}  } {
    global mc;
    set tl {};
    foreach i [$mc find withtag $name] {  if {[lsearch -exact [$mc itemcget $i -tags] wire ] < 0}  {lappend tl $i} 
    };
    set t [eval $mc create rect [eval $mc bbox $tl]  -fill red -tags "{$name bbox $selection}" ];
    $mc lower $t;set lx [$mc coords $t];
    eval $mc create text [expr ([ lindex $lx 0 ]+[ lindex $lx 2 ])/2 ]  [expr [lindex $lx 3]+1] -text $name  -tags "{$name bb blockname bbox $selection}"   -anchor n -fill red -font "{helvetica 12 bold}"
}

proc clength { {c }  } {
   set r [lindex $c 0] ;
   set c [lindex $c 1] ;
   set l [expr sqrt ($r*$r + $c*$c) ]
    return $l
}

proc cmul { {a } {b }  } {
   set ar [lindex $a 0]
   set ac [lindex $a 1]
   set br [lindex $b 0]
   set bc [lindex $b 1]
   set cr [expr $ar*$br - $ac*$bc]
   set cc [expr $ar*$bc + $ac*$br]
   set c [list $cr $cc]
   return $c
}

proc connect { {wire } {name1 } {pin1 } {name2 } {pin2 }  } {
    global mc wireindex
    #puts $wire,$name1,$pin1,$name2,$pin2
    set i1 [eval tag_and "{$name1 $pin1 pin}"]
    set i2 [eval tag_and "{$name2 $pin2 pin}"]
 #   set i1 [find2l $name1 $pin1];
 #   set i2 [find2l $name2 $pin2];
    #puts $i1,$i2;  
    set x1 [lindex [$mc coords $i1] 0];
    set y1 [lindex [$mc coords $i1] 1];
    set x2 [lindex [$mc coords $i2] 0];
    set y2 [lindex [$mc coords $i2] 1];
    #puts $x1,$y1,$x2,$y2;
    set match {}
    set t1 "{[lsort [list [list $name1 $pin1] [list $name2 $pin2]]]}"
    foreach i [$mc find withtag wire] {
       set t2 "{[lsort [list [lrange [$mc itemcget $i -tags] 3 4] [lrange [$mc itemcget $i -tags] 5 6] ] ]}"
       #puts "$t1,$t2"
       if { $t1 == $t2 } {
	  lappend match [lindex [$mc itemcget $i -tags] 0]
       }
    }
 #   puts $match
    if {$match == {}} {
       if {$wire == ""} {
	  set wire wire$wireindex
	  set wireindex [expr $wireindex+1]
       }
       eval $mc create line $x1 $y1 $x2 $y2 -fill darkblue  -tags "{$wire connect wire $name1 $pin1 $name2 $pin2}"
       set i [eval tag_and "{$name1 $pin1 pin}"]
       $mc itemco $i -fill darkblue
       $mc dtag $i selectedpin
       set i [eval tag_and "{$name2 $pin2 pin}"]
       $mc itemco $i -fill darkblue
       $mc dtag $i selectedpin
    } {
	  foreach i $match { $mc del $i}
    }
}


proc createscope { {name  {scope}}  } {
    global mc scopeindex
    
    if {$name == "scope"} {set name $name$scopeindex;
       set scopeindex [expr $scopeindex+1]
    }
    newblock $name 0 0 200 120 {in trigger}
    frame $mc.$name
    eval $mc create window 20 10 -anchor nw -height 100 -width 170  -tags "{$name crb scopewindow}" -window $mc.$name
 
    canvas $mc.$name.c -height 10 -width 10 -bg gray10
    pack $mc.$name.c -expand y -fill both
    $mc.$name.c create line 0 40 170 40 -fill gray30
    for {set i 1} {$i<1000} {set i [expr $i+1]} {  eval $mc.$name.c create line [expr $i-1]  [expr 40-(40/($i/100.0))*sin(2*3.1415*($i-1)/30 )] $i  [expr 40-(40/($i/100.0))*sin(2*3.1415*$i/30 ) ] -fill lightblue -tags "{$name createscope channel1}"
    }
    eval scrollbar  $mc.$name.s -orient horiz -command "{$mc.$name.c xview}"
    eval $mc.$name.c conf -xscrollcommand "{$mc.$name.s set}" -scrollregion  "{0 0 1000 100}"
    pack $mc.$name.s -side bottom -expand 0 -fill x
}

proc createshell { {name  {shell}}  } {
    global mc shellindex
    
    if {$name == "shell"} {set name $name$shellindex;
       set shellindex [expr $shellindex+1]
    }
    newblock $name 0 0 200 120 {command ouput do}
    frame $mc.$name ;
    eval $mc create window 20 10 -anchor nw -height 100 -width 170  -tags "{$name crb shellwindow}" -window $mc.$name
 
    set t $name; append t _entry
    entry $mc.$name.e -textvar $t
    eval set ttt   "{$mc.$name.t insert end \"\\n\$$t\\n\" tred;  $mc.$name.t insert end  \"\[eval \$$t\]\" tnavy; $mc.$name.t see end; $mc.$name.e selection range 0 end}"
 #   puts ,$ttt,
    button $mc.$name.b -text Eval -command  "$ttt"  -borderw 0 -padx 0 -pady 0
 #      "$mc.$name.t insert end \n\\\$$t\\n tred;  $mc.$name.t insert end  [eval \\\$$t]; $mc.$name.t see end; $mc.$name.e select 0 end"  # '{eval \$name"_entry}"
    pack $mc.$name.e -side bottom -anchor s -expand n -fill x
    pack $mc.$name.b -side bottom -anchor s -expand n -fill x
    text $mc.$name.t
    pack $mc.$name.t -side top -anchor n -expand n -fill both
    $mc.$name.t tag configure  tred  -foreground red -font "helvetica 8"
    $mc.$name.t tag configure  tnavy  -foreground navy -font "helvetica 8"
    bind $mc.$name.e <Return> "eval  $mc.$name.b invoke"
}


proc dbaccess { {title  {New Database}} {file  {tdb.tcl}} {fields  {{Name name} {Data "Data field"}}} {adbvar  {dbvar}}  } {
   global dbcurrent $adbvar currententry newcurrententry;
   if {[file exists $file] == 1} {
      set f [open $file r]; set dbvar [read $f]; close $f
   };
   set currententry 0
   set newcurrententry $currententry
   set dbcurrent [lindex $dbvar $currententry]; 

   if {[winfo exists .tc] == 0} {
      toplevel .tc; canvas .tc.c ; pack .tc.c  -expand y -fill both; 
   }
   dbform $dbcurrent; 
}

proc dbcontrol { {n }  } {
   global dbname
   toplevel .dbc
   wm title .dbc "Database Control"
   set dbname $n
   set w .dbc
      frame $w.f      
      entry $w.f.e -textvar dbname -width 30
      button $w.f.s -text Save -command {
	 global dbname currententry dbvar;
	 display_entry $currententry
	 set f [open $dbname w];
	 puts $f $dbvar; close $f
      }
      button $w.f.l -text Load -command {
	 global dbname
	 dbaccess [lindex [file split [file rootname $dbname]] end] $dbname
      }
      bind $w.f.e <Double-Button> {
	 set textname [tk_getOpenFile]
      }
      pack $w.f -side bottom -expand n -fill x      
      pack $w.f.e -side left -expand y -fill x      
      pack $w.f.s -side right      
      pack $w.f.l -side right      
      button $w.bnew -text "New Entry" -command {
      global dbvar newcurrententry
	 set tt [lindex $dbvar $currententry]
	 append dbvar " {"
	 foreach i $tt {
	    append dbvar [list [list [lindex $i 0] {}]] \ 
	 }
	 append dbvar "}"
	 set newcurrententry [expr [llength $dbvar]-1]
	 eval [bind .dbf.wb.ee <Return>]
   }
   pack $w.bnew
}

proc dbform { {fields } {title  {Data Form}} {window  {.dbf}} {fw  {20}} {ew  {20}}  } {
   global dbcurrent ccontent  cname cvars currententry
   global searchstring searchfields
   if {[winfo exists $window] == 0}  {toplevel $window}  {foreach i [winfo children $window] {destroy $i} };
   $window conf -bg white;
   label $window.t -text $title -font "helvetica 20" -bg yellow -fg blue;
   pack $window.t -anchor n -padx 2 -pady 2;

   list2array $fields

   foreach i $cvars {
      set wn [string tolower $i]; 
#      onefield $window.$wn $cname($i) ccontent($i) $fw $ew;
      onefield $window.$wn $i ccontent($i) $fw $ew;
   }
   global currententry newcurrententry
   frame $window.wb; pack $window.wb -side bottom -anchor s -fill x -expand n
   button $window.wb.ne -text Next -command {
      global newcurrententry dbvar
      if {$newcurrententry < [expr [llength $dbvar] -1]} {incr newcurrententry}
      display_entry $newcurrententry
   }
   pack $window.wb.ne -side right
   button $window.wb.pre -text Previous -command {
      global newcurrententry
      incr newcurrententry -1
      if {$newcurrententry < 0} {set newcurrententry 0}
      display_entry $newcurrententry
   }
   entry $window.wb.ee  -width 5 -textvar newcurrententry
   pack $window.wb.ee -side right
   bind $window.wb.ee <Return> {
      global newcurrententry currententry dbvar
      if {$newcurrententry > [expr [llength $dbvar] -1]} {
	  set newcurrententry $currententry }
      if {$newcurrententry < 0 } { set newcurrententry $currententry }
      display_entry $newcurrententry
   }
   pack $window.wb.pre -side right
   frame $window.ws; pack $window.ws -side bottom -anchor s -fill x -expand n
   label $window.ws.l -text "Search string, fields" -font "helvetica 12"
   pack $window.ws.l -side left
   entry $window.ws.es -textvar searchstring -width 16
   pack $window.ws.es -side right
   entry $window.ws.ef -textvar searchfields -width 10
   pack $window.ws.ef -side right
   bind $window.ws.es <Return> {
      global newcurrententry;
      set newcurrententry [lindex [lindex [dbsearch $searchstring $searchfields [list [expr $newcurrententry+1] end]] 0] 0];
      set t [bind .dbf.wb.ee <Return>];
      eval $t 
   }
}

proc dbimcan { {s }  } {
   global mc
   foreach i [$mc find withtag dbimages] {
      image del [lindex [$mc itemcget $i -tags ] 0]
   }
   $mc del dbimages dbtext
   set c 0
   foreach i $s {
      if {[catch "image create photo -file [lindex $i 2]" im] == 0}  {
	 puts $im; 
	 set m [$mc create image [expr 85+170*($c%5)] [expr 85+175*($c/5)] -anchor c -image $im -tag "$im dbimages"]
	$mc bind $m <Double-Button-1> "global newcurrententry
	set newcurrententry [lindex $i 0]
	eval {[bind .dbf.wb.ee <Return>]} " 
     }
     $mc create text [expr 85+170*($c%5)] [expr 166+175*($c/5)] -text [lindex $i 2] -font "helvetica 12 bold" -anchor n -tags "$im dbtext" ; 
     incr c
   }
   $mc raise dbtext 
}

proc dbsearch { {pattern } {fieldnames  {}} {range  {0 end}}  } {
   global dbvar
   set r {}
   set i [lindex $range 0]
   foreach d [eval "lrange [list $dbvar] $range"]  {
      foreach e $d {
	 if {$fieldnames != {}} {
	  foreach f $fieldnames {
	     if [string match $f [lindex $e 0]] {
		if [string match $pattern [lindex $e 1]] {
		    append r [list [list $i [lindex $e 0] [lindex $e 1] ]] \n
		}
	     }
	  }
	 } {
	    if [string match $pattern [lindex $e 1]] {
		append r [list [list $i [lindex $e 0] [lindex $e 1] ]] \n
	    }
	 }
      }
      incr i
   }
   return $r
}

proc delete_selblocks {  } {
    global mc;
    foreach i [listunion [$mc find withtag selection0] [$mc find withtag bb] ] {  foreach j [lindex [$mc itemcget $i -tags] 0] {
	   block_del $j ;
	   foreach k [$mc find withtag wire] {
	      if {[lsearch [$mc itemcget $k -tag] $j] > 0} {
		 $mc del $k
	      }
	   }
	}
     }
}

proc dfind { {p  {}} {g  {*}}  } {
#   only use from current directory with absolute path name
   set r {};
   if {$p == ""} {
      set p [pwd]
   } 
   set od [pwd];
   if {[file pathtype $p] == "absolute"} {
      set cb $p
   } else {
      set cb [pwd]
   }
   cd $p;
   if {[catch {glob *} l] == 0} {
#      puts \---$l
      foreach a [lsort -dict $l] {
	if {[string first \~ $a] < 0} {
	 if [file isdir $a] {
	     cd $cb
	    if {[string first \~ $a] < 0} {
	     append r "[dfind [file join $p $a] $g] "
	    }
	 }
       }
     }
      if {[catch "glob $g" f] == 0} {
	 foreach j $f {
	    if [file isfile $j] { 
	       append r "[list [file join $p $j]] " ;
	    }
	 }
      }
   } ;
   cd $od;
   return $r
}

proc display_entry { {n }  } {
    global dbcurrent currententry dbvar
    set dbcurrent [array2list]
    update_entry
    set currententry $n
    set dbcurrent [lindex $dbvar $currententry]
    set pf [focus -lastfor .dbf]
    dbform $dbcurrent
    set t "focus $pf" ;  catch $t
    update
    set t "$pf selection range 0 end" ; catch $t
    update
    set t "$pf icursor end" ; catch $t
}

proc Display_func { {l  {}}  } {
   global mc Display.In 
   eval { $mc itemconf [$mc find withtag text] -text ${Display.In} };
   #puts InDisplay
   return ok
}

proc drumscan { {bl  {drum0}} {tr  {bd hho hhc sd}}  } {
    global mc
    set maxi 0
    foreach k [listunion [$mc find withtag drumbol] [$mc find withtag $bl] ]  {
       if {[$mc itemcget $k -outline] != {}} {
	   eval lappend outlist \{  [string range [lindex [$mc itemcget $k -tag] 2]  4 end]  [string range [lindex [$mc itemcget $k -tag] 3]  4 end] \}
       }
       set ii [string range [lindex [$mc itemcget $k -tag] 3]  4 end]
       if {$ii > $maxi} {set maxi $ii}
    }
    set outlist [lsort -index 1 -int $outlist]
    
    set argi "len [expr 1000+(1000/8)*$maxi] 0 0\n"
    foreach i $outlist {
       append argi "s_[lindex $i 0] [expr [lindex $i end] * 2000.0 / 16]"
       switch [lindex $i 0] {
	  bd    {append argi " 200 0.9"}
	  sd    {append argi " 300 0.7"}
	  hhc   {append argi " 100 0.3"}
	  hho   {append argi " 200 0.15"}
	  ride  {append argi " 300 0.8"}
	  crash {append argi " 300 0.8"}
	  tamb  {append argi " 100 0.3"}
	   default   {append argi " 200 0.3"}
       }
       append argi "\n"
    }
 #   set f [open $bl.txt w]
 #      puts $f "len 2000"
 #      foreach i $outlist {
 #         puts $f "s_[lindex $i 0] [expr [lindex $i end] * 2000.0 / 16]"
 #      }
 #   close $f
    return $argi
}

proc dtree { {p  {}} {i  {0}}  } {
   set r {};
   if {$p == ""} {
      set p [pwd]
   };
   set od [pwd]; 
   cd $p;
   if {[catch {glob *} l] == 0} {
      foreach a [lsort $l] {
	 if [file isdir $a] {
	    for {set j 0} {$j < [expr 3*$i]} {incr j} {
	       puts -nonewline " "; append r " "
	    };
	    puts $a;append r "$a\n" ;
	    append r [dtree [file join $p $a] [expr $i+1]]
	 }
      }
   } ;
   cd $od;
   return $r
}

proc fac { {f }  } {if {$f >1} {
     return [expr [fac [expr $f-1]] * $f]
  } {
      return $f
   }
}

proc find { {p  {.}} {s  {*}}  } {
   set r {} ; 
   foreach i [glob $s] {
      if {[file isdir $i] == 0} {
	  append r [file join $p $i] " "
      }
   }
}

proc find2l { {l1 } {l2 }  } {
    global mc
    foreach i [$mc find withtag $l1] {  if {[lsearch [$mc itemcget $i -tags]  $l2 ] >= 0}  {return $i}
    } 
}

proc fire { {b }  } {
 eval "b_eval" 
}

proc firefull {  } {
   global mc
   set o {};
   foreach i [tag_and block] {
      lappend o [lindex [$mc itemcget $i -tags] 0]
   }
   firelist $o
}

proc firelist { {l }  } {
   global bfunc t
   #puts "lenght: [llength $l]"
   set m [llength $l]
   for {set i 0} {$i < $m} {incr i} {
      #puts "i=$i"
      foreach n $l {
	 #puts *********$n**********
	 transfer $l
	 set f {}
	 append f  [blockfunc $n {}] 
	 global $f
	 #puts 1,$f
	 eval set fc \$\{$f\}
	 #puts 2,$f,$fc
	 set t $fc
	 #puts \[\[\[$t\]\]\]
	 #puts "executing: $f,$fc,$$f,$t"
	 uplevel #0  $t ;
	 #puts *********************
      }
   }
}

proc flood { {block } {pin }  } {
    global mc;
    set delay 1000;
    if {$block == {} && $pin == {} } {return {}};
    showactive $block $pin red; update;
    foreach w [pin_get_wirenames $block $pin] {
       set nb [lindex [wire_other $w $block $pin] 0];
       foreach o [block_get_pinnames $nb typeout] {
	  eval "after $delay {flood $nb $o}"
       }
    };
    eval "after $delay showactive $block $pin navy"; update
}


proc gen_drumtrack { {bl  {drum}} {tr  {bd hho hhc sd ride crash tamb}} {steps  {16}}  } {
    global mc drumindex
    
    if {$bl == "drum"} {set bl $bl$drumindex;
       set drumindex [expr $drumindex+1]
    }
    
 #   newblock $bl 0 0 220 120 {trigger_in trigger_out command}
 #   $mc create rect 10 10 210 110 -fill white -tags "$bl newblock workp"
    set ym [expr [llength $tr]-1]
    newblock $bl 0 0 [expr 36+8*($steps)] [expr 60+$ym*20 ] {trigger_in trigger_out command}
    $mc create rect 10 10 [expr 36+8*($steps)-10] [expr 60+$ym*20-10 ] -fill white -tags "$bl newblock workp"
 
    set j 0
       for {set i 0} {$i < $steps} {set i [expr $i+4]} {
	   $mc create line [expr 21 + 8*$i] 10  [expr 21 + 8*$i]  [expr 60+$ym*20-10 ] -fill blue  -tags "$bl sepa"
       }
    foreach n $tr {
       $mc create line 10 [expr $j*20+30] [expr 36+8*($steps)-10] [expr $j*20+30] -fill red -tags "$bl workp $n"
       $mc create text 10 [expr 20*$j+27] -text "$n" -tags "$bl workp  text$n"  -fill blue -anchor sw
       for {set i 0} {$i < $steps} {set i [expr $i+1]} {  $mc create oval [expr 18 + 8*$i] [expr 20*$j+27]  [expr 24 +8*$i] [expr 20*$j+33] -fill red -outline {}  -tags "$bl drumbol drtr$n drtr$i" ;  }
       set j [expr $j+1]
    }
}


proc gen_html_page { {title } {body }  } {
   set o {}
   append o <html> \n <title> $title </title> \n
   append o <body> \n
   append o <h2> $title </h2> \n  <p> \n
   append o $body
   append o </body>
   append o \n </html>
   return $o
}

proc gen_netlist {  } {
    global mc
    set o ""
    foreach w [tag_and wire] {
       append o "connect [lindex [$mc itemcget $w -tags] 0] [lrange [$mc itemcget $w -tags] 3 6] \n"
    }
    return $o
}

proc genadd { {a } {b } {c } {d }  } {
#  {f {}} {name {}} {in {in}} {out {out}} {width {40}} {height {}} {tags {}} {x {10}} {y {10}} 

   set n add11
   newproc "set $n.o \[expr \${$n.a} + \${$n.b}\]" $n {a b} o 40 {} {add} 
   set n add12
   newproc "set $n.o \[expr \${$n.a} + \${$n.b}\]" $n {a b} o 40 {} {add} 
   set n add13
   newproc "set $n.o \[expr \${$n.a} + \${$n.b}\]" $n {a b} o 40 {} {add} 
   connect wa10 add11 a  $a $b
   connect wa11 add11 b  $c $d
   connect wa12 add12 a  $a $b
   connect wa13 add12 b  $c $d
   connect wa14 add13 a  $a $b
   connect wa15 add13 b  $c $d

   set n add21
   newproc "set $n.o \[expr \${$n.a} + \${$n.b}\]" $n {a b} o 40 {} {add} 
   set n add22
   newproc "set $n.o \[expr \${$n.a} + \${$n.b}\]" $n {a b} o 40 {} {add} 
   connect wa1 add11 o add21 a 
   connect wa2 add12 o add21 b 
   connect wa3 add13 o add22 b 
   connect wa4 add12 o add22 a 

   set n add31
   newproc "set $n.o \[expr \${$n.a} + \${$n.b}\]" $n {a b} o 40 {} {add} 
   connect wa5 add21 o add31 a 
   connect wa6 add22 o add31 b 

}

proc genwire {  } {
    global mc
    set t [lrange [$mc find withtag selectedpin] 0 1]
    if {[llength $t] == 2} { 
	  connect {}    [lindex [$mc itemcget [lindex $t 0] -tags] 0]  [lindex [$mc itemcget [lindex $t 0] -tags] 3]  [lindex [$mc itemcget [lindex $t 1] -tags] 0]  [lindex [$mc itemcget [lindex $t 1] -tags] 3]
    }
}

proc get_procvanilla {  } {
   global defaultprocs ;
   set f [open defaultprocs.tcl r];
   if {$f == {}} {return -1}
   set defaultprocs [ read $f ] ;
   close $f
   return 0
}

proc get_varvanilla {  } {
   global defaultvars ;
   set f [open defaultvars.tcl r];
   if {$f == {}} {return -1}
   set defaultvars [ read $f ] ;
   close $f
   return 0
}


proc grep { {a } {fs  {*}}  } {
   set o {}
   foreach n [lsort -incr -dict [glob $fs]] {
      set f [open $n r]
      set c 0
      set new 1
      while {[eof $f] == 0} {
	 set l [gets $f]
	 incr c
	 if {[string first $a $l] > -1} {
	    if {$new == 1} {set new 0; append o "*** $n:" \n}
	    append o "$c:$l" \n
	 }
      }
      close $f
   }
   return $o
}


proc l { {n  {*}}  } {
set r {} ; foreach f [lsort -dict [glob $n]] {if {[file isdir $f] == 0} {append r $f \t } {append r $f \\ \t }} ; return $r 
}

proc list2array { {list } {na  {cname}} {va  {ccontent}} {names  {cvars}}  } {
   upvar  #0 $na n  $va v 
   if {$names != {}} {upvar #0 $names x}
   if {[info exists n] == 1} {unset n}
   if {[info exists v] == 1} {unset v}
   set x {}
   foreach i $list {
      set a [lindex $i 0]; set b [lindex $i 1]; set c [lindex $i 2]
      if {$c == {}} {set c $a}
      lappend x $c
      set n($c) $a; set v($c) $b
   }
}


proc listunion { {a } {b }  } {
    global mc
    set l {}; 
    foreach i $a  {  if {[lsearch -exact $b $i] >= 0}  {lappend l $i}  } ;
    return $l
}

proc loaddb { {fn  {dbtab.txt}}  } {
   global db
   set db {}
   set f [open $fn r]
   while {[eof $f] ==0} {append db \{ [gets $f] \} \n}
   close $f
}

proc main_window { {root } {lproject }  } {
    global mw mc project
    set mw $root.mw
    set mc $mw.c
    set project $lproject
    
    catch {destroy $mw [winfo children $mw]}
    if {$root == ""} {
       wm title . Bwise
       wm geometry . 500x350
    }
    frame $mw -width 400 -height 300;
       pack $mw -side bottom  -expand y -fill both -anchor s
    scrollbar $mw.hscroll -orient horiz -command "$mc xview"
    scrollbar $mw.vscroll -command "$mc yview"
    canvas $mc -width 1000 -height 800 -bg gray80  -scrollregion {0 0 1000 800}  -xscrollcommand "$mw.hscroll set"  -yscrollcommand "$mw.vscroll set"
    pack $mw.vscroll -side right -fill y
    pack $mw.hscroll -side bottom -fill x
    pack $mc -side right -expand n -fill both
}

proc mainbuttons { {root }  } {
    global mw bwisepath
    set mb $root.fb
    catch {destroy $mb}
    frame $mb 
       pack $mb -side top -fill x -expand y -anchor n
    button $mb.bnewb -text "New Block" -command {newblock {} }
    pack $mb.bnewb -side left -fill none -expand n
    if {$root == ""}  {global tcl_interative; button $mb.quit -text "Quit" -command {eval destroy [winfo children .];  if {$tcl_interactive == 0} {destroy .}  }  }  {button $mb.quit -text "Quit" -command "eval destroy [winfo children $root]" }
    pack $mb.quit -side right -fill none -expand n
    
#    image create photo paperim -file $bwisepath/paper.gif
    image create photo paperim -file paper.gif
    button $mb.p -image paperim -borderw 0 -padx 0 -pady 0 -relief flat -command createshell
    pack $mb.p -side left
    button $mb.bwire -text "Wire" -command genwire -fg green
       pack $mb.bwire -side left -fill none -expand n
    
    button $mb.bcdrum -text "Drum" -command gen_drumtrack
    button $mb.bcscope -text "Scope" -command createscope
    pack $mb.bcdrum -side left
    pack $mb.bcscope -side left
    button $mb.bscan -text "Scan Drum" -command  {exec drumip.exe drum0.wav << [drumscan] &}
    pack $mb.bscan -side right -fill none -expand 0
    button $mb.bdel -text "Del Sel" -command delete_selblocks
    pack $mb.bdel -side right -expand n -fill none
    button $mb.bsave -text "Save" -command save_canvas
    pack $mb.bsave -side right -fill none -expand 0
    button $mb.bload -text "Load" -command {reload_canvas}
    pack $mb.bload -side right -fill none -expand 0
}

proc matdiag { {n  {3}} {e  {1}}  } {
   set a "\{ " ; set a {}
   for {set i 0} {$i<$n} {incr i} {
      set r "\{ "; 
      for {set j 0} {$j<$n} {incr j} {
	 #puts $i,$j
	 if {$i == $j} {
	    append r " $e"
	 } {
	    append r " 0"
	 }
      } ; 
      append r " \} ";
      append a $r
   } ; 
   #append a " \}"; 
   return $a
}

proc matmul { {a } {b }  } {
   set r {}
   set n [llength $a]
   foreach s $b {
      for {set i 0} {$i<$n} {incr i} {
	 set t 0
	 for {set j 0} {$j < $n} {incr j} {
	    set t [expt $t+]
	 }
	 append r 
      }
   }
}

proc matprint { {a }  } {
   foreach r $a {
      puts "$r"
   }
}

proc matsweep { {a } {b }  } {
   #incomplete
   set x {}
   for {set i 0} {$i < [llength $b]} {incr i} {append x "0 "}
   for { set i [llength $a] } {$i >= 0} {incr i -1} {
      set r [lindex $a $i]
      puts $r
      set w {}

      set d [expr [lindex $r 0] / [lindex $b i]
      foreach {set j 0} {$j < [llength b]} {incr j} {
	  append w " [expr []-[lindex $r $j]/$d]" 
      }
   }
   return $x
}

proc netlistout { {tag  {}}  } {
    set o {};
    foreach id [eval tag_and "{block $tag}"] {
       set bl [block_name_fromid $id];
       foreach pin [block_get_pinnames $bl typeout] {
	  foreach wire [pin_get_wirenames $bl $pin] {
	     set ot [wire_other $wire $bl $pin];
	     if {$ot != {}} {
		lappend o "$bl $pin $ot"
		# puts "$bl $pin $ot"
	     }
	  }
       }
    }
    return $o;
}

proc newadd { {nin } {name }  } {
   set in "\{"
   set f  "\{set $name.out \[ expr "
   for {set i 0} {$i < $nin} {incr i} {
      append in " in$i"
      append f  " + \$\{$name.in$i\}"
   }
   append f  " \]\}"
   append in " trig \} "
   eval newproc "$f $name $in"
}

proc newarray { {nx  {3}} {ny  {3}} {bn  {array}} {fs  {}} {ib  {}} {ipi  {}} {jb  {}} {jpi  {}}  } {
   for {set i 0} {$i < $nx} {incr i} {
      for {set j 0} {$j < $ny} {incr j} {
	 if {$fs == {}} {eval  "set f \{ set $bn${i}_$j.o {} ; append \{$bn${i}_$j.o\} \$\{$bn${i}_$j.i1\} \$\{$bn${i}_$j.i2\}  \}"}
	 newproc $f $bn${i}_$j {i1 i2} {o} {40} {} {array a${i}_$j}  [expr 200 + 80 * $i] [expr 200 + 60 * $j]
	 set ip [expr $i -1] ; set jp [expr $j -1]
	 if {$i>0} { connect ${bn}1${i}_$j $bn${ip}_$j o $bn${i}_$j i1}  {if {$ib != {}} {connect ${bn}1${i}_$j $ib $ipi $bn${i}_$j i1} }
	 if {$j>0} { connect ${bn}2${i}_$j $bn${i}_$jp o $bn${i}_$j i2}  {if {$jb != {}} {connect ${bn}2${i}_$j $jb $jpi $bn${i}_$j i2} }
      }
   }
}

proc newblock { {name  {}} {x  {0}} {y  {0}} {w  {50}} {h  {50}} {pinsin  {in1 in2}} {pinsout  {}} {moretags  {}}  } {
    global bcount mw mc
    if {$name == ""} {set name "block$bcount" ; set bcount [expr $bcount +1]}
    eval $mc create rect $x $y [expr $x+$w] [expr $y+$h]  -tags "{$name newblock block $moretags}" -fill yellow -outline darkblue
    eval $mc create text  [expr $x+$w/2] [expr $y+$h]  -anchor n -text $name -fill darkblue -tags "{$name crb label $moretags}"
    set ii 0
    foreach i $pinsin {
       eval $mc create text [expr $x-1] [expr $y+19+$ii]  -anchor se -text $i -tags "{$name crb pinname $i $moretags}"
       eval $mc create line  [expr $x-20] [expr $y+20+$ii] [expr $x+0] [expr $y+20+$ii]  -width 2 -fill darkblue  -tags "{$name newblock pin $i typein $moretags}"
       set ii [expr $ii+15]
    }
    set ii 0
    foreach i $pinsout {
       eval $mc create text [expr $x+$w+1] [expr $y+19+$ii]  -anchor sw -text $i -tags "{$name crb pinname $i $moretags}"
       eval $mc create line  [expr $x+$w+20] [expr $y+20+$ii] [expr $x+$w+0] [expr $y+20+$ii]  -width 2 -fill darkblue  -tags "{$name newblock pin $i typeout $moretags}"
       set ii [expr $ii+15]
    }
}

proc newdisp { {name }  } {
   global mc $name.bfunc
   newblock $name 10 10 70 90 {in trig}
   for {set x 0} {$x < 5} {incr x} {
      for {set y 0} {$y < 7} {incr y} {
	 $mc create oval [expr $x*10+22] [expr $y*10+22] [expr $x*10+22 +6] [expr $y*10 + 22 +6] -fill red -tags "$name ll dot x$x y$y"
      }
   }
   blockclear $name
   set $name.bfunc "for {set x 0} {\$x < 5} {incr x} { for {set y 0} {\$y < 7} {incr y} { \$mc itemco \[tag_and \"$name dot x\$x y\$y\"\] -fill \[lindex \${$name.in} \[expr \$x*7+\$y\]\]  } }"
}

proc newentry { {width  {60}} {height  {30}} {tags  {}} {name  {}}  } {
   if {$name == {}} {
       uplevel #0 {if {[info exists entrycount] == "0"} {set entrycount 0} ;}
      global entrycount
      incr entrycount
      set name Entry$entrycount
   }
   set t [blockfunc $name]
   global mc $t; 
   #eval "global mc ; set $t {$mc.$name select range 0 end}"
   newblock $name 0 0 $width $height {} out $tags
   blockclear $name
   set lc [string tolower $name]
   entry $mc.$lc -width 5 -textvar $name.out
   $mc create window 3 5  -window $mc.$lc   -tags "{$name}" -anchor nw
   bind $mc.$lc <Return> " uplevel #0 run $name"
   return $name
}

proc newimage { {file }  } {
   global mc
   set imn [lindex [file split [file rootname $file]] end]
   set im [image create photo $imn -file $file]
   set w [image width $im] ; set h [image height $im]
   newproc {} $im in out $w $h
   $mc create image 10 10 -image $im -tags "$im newimage block image" -anchor nw
}

proc newmon { {keep  {0}} {width  {80}} {height  {65}} {tags  {}} {name  {}}  } {
   if {$name == {}} {
      uplevel #0 {if {[info exists moncount] == "0"} {set moncount 0} ;}
      global moncount
      incr moncount
      set name Mon$moncount
   }
   set t [blockfunc $name]
   global mc $t;
   #eval "global mc ; set $t {$mc.$name select range 0 end}"
   newblock $name 0 0 $width $height {in trig} {} $tags
   blockclear $name
   set lc [string tolower $name]
   text $mc.$lc -width 12 -height 5 -font "helvetica 7" -borderwidth 1 -border 1
   $mc create window 4 4  -window $mc.$lc   -tags "{$name}" -anchor nw
   #bind $mc.$lc <Return> " uplevel #0 run $name"
   if {$keep != 0} {
      set $t "$mc.$lc insert end \"\$\{$name.in\} \\n\" ; $mc.$lc see end"
   } {
      set $t "$mc.$lc del 0.0 end ;$mc.$lc insert end \"\$\{$name.in\} \\n\" ; $mc.$lc see end"
   }
   return $name
}

proc newproc { {f  {}} {name  {}} {in  {in}} {out  {out}} {width  {40}} {height  {}} {tags  {}} {x  {10}} {y  {10}}  } {
   if {$name == {}} {
       uplevel #0 {if {[info exists proccount] == "0"} {set proccount 0} ;}
      global proccount
      incr proccount
      set name Proc$proccount
   }
   set t [blockfunc $name]
   global mc $t; 
   set $t {}
   if {$height == {}} {
      if {[llength $in] > [llength $out]} {
	 set height [expr 15+ 15 * [llength $in]] } {
	 set height [expr 15+ 15 * [llength $out]]
      }   
   }
   newblock $name $x $y $width $height $in $out $tags
   blockclear $name
   if {$f == {}} {
      eval  "set f \{ set $name.out \$\{$name.in\} \}"
   }
   set $t $f
   return $name
}

proc newseq { {n  {8}} {name  {}} {del  {500}}  } {
   if {$name == {}} {
      uplevel #0 {if {[info exists seqcount] == "0"} {set seqcount 0} ;}
      global seqcount
      incr seqcount
      set name Seq$seqcount
   }
   set t [blockfunc $name]
   global mc $t;
   set oo {}
   for {set i 0} {$i < $n} {incr i} {append oo " o$i"}
#   set ttt "{clkb clka c $oo }"
#   puts $ttt
   newproc {} $name {trig} [eval list clkb clka c $oo] 40 {} seq
   blockclear $name
   set lc [string tolower $name]
   set $t "for {set o 0} {\$o < $n} {incr o} { after \[expr int($del*(\$o+1-0.5))\] \"trig $name clkb\" ; after \[expr int($del*(\$o+1))\] \" set $name.c \$o; trig $name o\$o\" ; after \[expr int($del*(\$o+1.5))\] \"trig $name clka\" }"
   return $name
}

proc newstack { {name  {}}  } {
   if {$name == {}} {
       uplevel #0 {if {[info exists stackcount] == "0"} {set stackcount 0} ;}
      global stackcount
      incr stackcount
      set name Stack$stackcount
   }
   set stack $name.stack
   set t [blockfunc $name]
   global $stack $t
   newproc {} $name {in mode trig} {stack out}
   blockclear $name

set f "
      global $stack $name.mode $name.in $name.trig $name.out
      puts \${$name.mode}
      puts \${$stack},\${$name.mode}
      switch \${$name.mode}  clear {puts c; set $stack {}}  push  {puts u; append $stack \\ \\\{ \$\{$name.in\} \\\} }  pop   {puts o,\[lrange \$\{$stack\} 0 \[ expr \[llength \{$stack\}\] -1\]\]; set $name.out \[lindex \$\{$stack\} end\];
		 if {\[llength \${$stack}\] == 1} {puts ---1---; set $stack {}} {
		 set $stack \[lrange \${$stack} 0 \[ expr \[llength \${$stack}\] -2\]\] }  }  idle  {puts i}  default {puts d};
   "
   set $t $f
   return $name
}

proc newtext { {width  {60}} {height  {40}} {tags  {}} {name  {}}  } {
   if {$name == {}} {
       uplevel #0 {if {[info exists textcount] == "0"} {set textcount 0} ;}
      global textcount
      incr textcount
      set name Text$textcount
   }
   set t [blockfunc $name]
   global mc $t; 
   set $t {}
   #uplevel #0 {if {[info exists textcount] == "0"} {set textcount 0} ;}
   #global textcount mc 
   #incr textcount
   #set name Text$textcount
   #set t "{$name.bfunc}" ; global $t
   puts $t
   newblock $name 0 0 $width $height in {} $tags
   blockclear $name
   $mc create text 6 10 -text $name -anchor nw -fill navy  -font "courier 10" -tags "$name textfield"
   set $t "global mc; \$mc itemco \[tag_and { $name textfield }\] -text \$\{$name.in\} "
   return $name
}

proc onefield { {path } {label } {var } {width1  {20}} {width2  {20}}  } {
   frame $path; pack $path -expand n -fill none;
   label $path.l -text $label -font "helvetica 15" -bg grey90 -width $width1;
   pack $path.l -side left;
   global $var;
   entry $path.e -textvar $var -font "courier 15" -width $width2;
   pack $path.e -side left -expand y -fill x 
   
   if {$label == "Image"} {
      global ccontent 
      eval set file $$var
      .tc.c del image ; catch "{image delete tcim}"
      catch "set lim [image create photo tcim -file $file  ] ;
      .tc.c create image 1 1 -anchor nw -image tcim -tag image"
   }
}


proc open_text { {n  {}}  } {
   global textname
   if {[winfo exists .tt] == 0} {
      toplevel .tt
      set textname $n
      text .tt.t -width 40 -height 8
      frame .tt.f
      entry .tt.f.e -textvar textname -width 30
      button .tt.f.s -text Save -command {
	 global textname;  set f [open $textname w];
	 puts $f [.tt.t get 0.0 end]; close $f 
      }
      button .tt.f.l -text Load -command {
	 global textname; .tt.t del 0.0 end; 
	 set f [open $textname r]; 
	 while {[eof $f] == 0} {
	    .tt.t insert end "[gets $f] \n"
	 }; close $f 
      }
      bind .tt.f.e <Double-Button> {
	 set textname [tk_getOpenFile]
      }
      pack .tt.t -expand y -fill both
      pack .tt.f -side bottom -expand n -fill x
      pack .tt.f.e -side left -expand y -fill x
      pack .tt.f.s -side right
      pack .tt.f.l -side right
   } {
      set textname $n
   }
   if {$textname != {}} {
      .tt.f.l invoke
   }
}

proc otherpins { {block } {pin }  } {
 set o {}; foreach w [pin_get_wirenames $block $pin] {lappend o [wire_other $w $block $pin]} ; return $o 
}

proc pin_get_wirenames { {block } {pin }  } {
    global mc;
    set o {}; 
    foreach i [eval "tag_and {wire $block $pin}"] {
       eval "set w {[$mc itemcget $i -tags]}";
       if {[lrange $w 3 4] == [list $block $pin] || [lrange $w 5 6] ==  [list $block $pin]} {
	  lappend o [lindex $w 0]}
       }; 
    return $o
}

proc pinvar { {block } {pin }  } {
   append o $block . $pin  ;
   return $o
}

proc procs_window {  } {
	   global defaultprocs
	   if {[info exists defaultprocs] != 1} {
	      set defaultprocs {}
	   }
	   get_procvanilla
	   toplevel .f
	   listbox .f.l -height 5 ; pack .f.l -expand n -fill x
	   text .f.t -width 20 -height 4 -wrap none ;
	   pack .f.t -expand y -fill both
	   frame .f.f; pack .f.f -expand n -fill x
	   button .f.f.b -text {Update Proc} -command {
	      global procs;
	      set p [.f.t get 0.0 end];
	      eval $p;
	      set procs([lindex $p 1]) $p
	   }
	   pack .f.f.b -side right
	   bind .f.l <Double-Button-1> {
	      global cf; set cf [selection get];
	      .f.t del 0.0 end;
	      .f.t insert end "proc $cf \{"
	foreach a [info args $cf] {
	   if { [info default $cf $a b] == 1} {
	      .f.t insert end " {$a {$b}}" } {
	      .f.t insert end " {$a}"
	   }
	}
       .f.t insert end " \} \{[info body $cf]\} "
	   }
	   button .f.f.b2 -text "Refresh List" -command {
	      set o {};
	      foreach i [info procs] {
		 if {[string match {tk*} $i] == 0 && 
		 [string match {tcl*} $i] == 0 &&
		 [lsearch $defaultprocs $i] == -1 } {
		    lappend o $i
		 }
	      };
	     .f.l del 0 end;
	      foreach i [lsort $o] {.f.l insert end $i}
	   };
	   pack .f.f.b2 -side right
	   entry .f.f.f -width 15 -textvar procsfile
	   pack .f.f.f -side left
	   button .f.f.bs -text {Save Procs} -command {
	      global procsfile procs
	      set o {}
	      foreach i [lsort [array names procs]] {
		 eval append o { $procs($i) } \n 
	      }
	      set f [open $procsfile w];
	      puts $f $o;
	      close $f
	   }
	   pack .f.f.bs -side left
   bind .f.l  <F1> [bind .f.l [bind .f.l ]]     
}

proc readccat {  } {
   foreach i  [split [lindex [split $w \t] 0] {}] {  set k [lindex [array get ha $i] 1];  if {$k != {} } {if {$k == " "}  {$wt insert insert " "; $wt mark set insert insert-1c}  {eval $bh.b$ha($i) invoke}}
   }
}

proc reload_canvas {  } {
    global mc
    set fn [tk_getOpenFile];
    if {$fn != ""} {
       $mc del all
       foreach i [winfo children $mc] {destroy $i}
       source $fn
    }
}

proc reloadpage { {user  {0}}  } {
   set o "<html>\n[servhtml $user 0]"
   append o "<P>\n<a href=\"/reloadpage?user=$user\">Load lastest page update</a>\n</html>\n"
   return $o
}

proc remprocnls {  } {
   set ci 0      
   foreach cf [.f.l get 0 end] {      
   #puts $cf,$ci      
      .f.l see $ci      
      .tt.t del 0.0 end      
      .tt.t insert end "proc $cf \{"      
      foreach a [info args $cf] {      
	   if { [info default $cf $a b] == 1} {      
	      .tt.t insert end " {$a {$b}}" } {      
	      .tt.t insert end " {$a}"      
	   }      
      }      
      .tt.t insert end " \} \{[info body $cf]\} "      
	    
      set c 100; while { ( [.tt.t get 2.0 3.0] == "\n" || [.tt.t get 2.0 3.0] == " \n" || [allspaces [.tt.t get 2.0 2.end]] == 1 ) && $c > 0} {.tt.t del 2.0 3.0 ; incr c -1; update}      
      set c 100; while { ( [.tt.t get end-2line end-1line] == "\n" || [.tt.t get end-2line end-1line] == "\n" || [allspaces [.tt.t get end-2line end-1line-1char]] == 1 ) && $c > 0} {.tt.t del end-2line end-1line ; incr c -1; update}      
      eval "[.tt.t get 0.0 end]"      
      incr ci      
   }      
}


proc run { {block } {pins  {}} {mode  {}}  } {
    global mc;
    set delay 600;
    global ident ; set idento {}; for {set i 0} {$i < $ident} {incr i} {append idento "     "} ; incr ident +1 ; 
    #puts "******$block*******,$pins,$mode"
    if {$block == {}} {return {}};
    if {$pins == {}} { set pins [block_get_pinnames $block {pin typeout}] }
    transfer $block
    foreach pin $pins {
	#puts -nonewline ^
       if {$block == {} && $pin == {} } {return {}};
       if {$mode != ""} {showactive $block $pin red; update; }
       foreach w [pin_get_wirenames $block $pin] {
	  #puts $idento,_$w
	  #puts -nonewline &
	  set nb [lindex [wire_other $w $block $pin] 0];
	  #if {$block == "$block"} {puts "$idento$pin,$w,$nb"}
	   uplevel #0 eval $\{[blockfunc $nb]\}
	  if {$mode == "delay"} {
	      #puts ***$nb,$pins,$mode
	     after $delay uplevel #0 run "$nb {{}} $mode" } {
	     uplevel  #0 run $nb {{}} $mode
	  # foreach o [block_get_pinnames $nb typeout] {
	  #    }
	  }
       }
       if {$mode != ""} {eval "after $delay showactive $block $pin navy"; update };
    };
   incr ident -1
}

proc save_blocks { {file } {blocks }  } {
   set f [open $file w]
   foreach b $blocks {
      
      puts $f "set $b ${$b.bfunc}"
   }
   close $f
}

proc save_canvas {  } {
    global mc
    set o ""
    set sv {bcount scopeindex wireindex shellindex drumindex}
    eval global $sv
    eval {append o global " " $sv \n}
    foreach i $sv {
       eval set j $$i
       append o set " " $i " " $j \n
    }
    foreach in [image names] {
       append o "image create photo " $in " -file " [$in cget -file] \n
    }
    foreach i [$mc find all] {
       if {[$mc type $i] != "window"} {
	  append o $mc " " create " " [$mc type $i] " " [$mc coords $i]
	  foreach k [ $mc itemco $i] {
	     append o " " [lindex $k 0] " " [list [lindex $k end]]
	  }
	 append o \n }
    }
    set fn [tk_getSaveFile];
    if {$fn != ""} {
       set fd [open $fn w];
       puts $fd $o; close $fd 
    }
}

proc save_canvasvars { {n }  } {
   global nnn
   set nnn $n
   uplevel #0 {
      set ooo {}
      foreach bi [tag_and {block}] {
	set b [block_name_fromid $bi]
       foreach i [lsort -dict [info vars $b.*]] {
	 if {[string index $i 0] != "\$" && 
		 [array exists $i] == 0} {
	      eval set ttt $\{$i\}
	      #set uuu "set \{$i\} \{$ttt\} \n"
	      #eval set uuu $\{$i\}
	      append ooo "set " $i " " \{ $ttt \} \n
	  }
       }
      }
      set f [open $nnn w];
      puts $f $ooo;
      close $f
   }
}

proc save_procs { {n }  } {
      global procsfile procs
      set o {}
      foreach i [lsort [array names procs]] {
	 eval append o { $procs($i) } \n 
      }
      set f [open $procsfile w];
      puts $f $o;
      close $f
}

proc save_procs2 { {n }  } {
   global nnn
   set nnn $n
   uplevel #0 {
      set ooo {}
      foreach i [lsort -dict [info procs]] {
	 if {[lsearch $defaultprocs $i] == -1 &&
		 [string index $i 0] != "\$" } {
#              eval set ttt $\{$i\}
#              set uuu "set \{$i\} \{$ttt\} \n"
#              eval set uuu {}
	      #append ooo "set " $ttt " " $uuu \n
	      append ooo "proc $i { "
	      foreach a [info args $i] {
		  set d ""
		  if {[info default $i $a d]} {set d " {$d}"}
		  append ooo "{$a $d} "
	      }
	      append ooo " } {" [info body $i] "}\n\n"
	  }
      }
      set f [open $nnn w];
      puts $f $ooo;
      close $f
   }
}

proc save_procs_bak { {n }  } {
   set o {}
   foreach i [lsort [array names procs]] {
      eval append o { $procs($i) } \n 
   };
#   puts $o
   set f [open {procs.tcl} w];
   puts $f $o;
   close $f
}

proc save_vars { {n }  } {
   global nnn
   set nnn $n
   uplevel #0 {
      set ooo {}
      set defaultvars {defaultvars ooo nnn ttt}
      foreach i [lsort -dict [info vars]] {
	 if {[string match {tk*} $i] == 0 && 
		 [string match {tcl*} $i] == 0 &&
		 [lsearch $defaultvars $i] == -1 &&
		 [string index $i 0] != "\$" && 
		 [array exists $i] == 0} {
	      eval set ttt $\{$i\}
	      set uuu "set \{$i\} \{$ttt\} \n"
	      eval set uuu {}
	      #append ooo "set " $ttt " " $uuu \n
	      append ooo  $uuu
	  }
      }
      set f [open $nnn w];
      puts $f $ooo;
      close $f
   }
}

proc savefile { {wn  {0}}  } {
   global wt
   set t [tk_getSaveFile]
   if {$t == {}} return
   set fd [open $t w]
   if {[file writable $t] == 0} {close $fd ; return }
   puts $fd [$wt($wn) dump -text -image 0.0 end]
   close $fd
}

proc savehis { {file }  } {
    set f [open $file w];
    puts $f [history];
    close $f
}

proc savehist { {n }  } {
set f [open $n w]; puts $f [history] ; close $f
}


proc send { {line  {
}}  } {
   global sock
   if {$sock == -1} {
      log "(failed attempt to send:\n$line)\n"
      return
   }
   puts $sock $line
   flush $sock
   log $line\n
}


proc set_varvanilla {  } {
   global defaultvars 
   set defaultvars [lsort [info procs]]
}

proc setbfunc { {b } {f } {t  {}}  } {
   global bfunc
   
   set fn [blockfunc $b $t]
   set $fn $f
}

proc showactive { {block } {pin } {c }  } {
    global mc;
    if {$c == {}} {return};
    $mc itemco [ eval "tag_and {pin $block $pin}"] -fill $c
}

proc showentry { {ind  {0}}  } {
   global db fb de currentid
   if {[winfo exists .db] == 0} { 
      toplevel .db
      frame .db.f1 ; pack .db.f1
      set fb .db.f1
   }
   if {[winfo exists .db.fc] == 0} {
      frame .db.fc
      pack .db.fc -side bottom -expand 0 -fill x
      button .db.fc.bn -text next  -command {global currentid ; incr currentid; 
	showentry $currentid }
      pack .db.fc.bn -side right
      button .db.fc.bp -text Previous -command {
	  global currentid ; incr currentid -1; 
	  showentry $currentid } ; 
      pack .db.fc.bp -side right
      entry .db.fc.en -textvar currentid -width 4 ;
      pack .db.fc.en -side right
      bind .db.fc.en <Return> {global currentid; showentry $currentid}
   }
   foreach i [winfo children .db.f1] {destroy  $i}
   set i 0
   set de [split [lindex $db $ind] \t]
   #puts $de
   foreach d $de {
     if {$d != {}} {
      frame $fb.f$i;
      label $fb.f$i.l -text $i;
       #puts de$i,$d
      global de$i
      set de$i $d;
      entry $fb.f$i.e -textvar de$i;
      pack $fb.f$i;
      pack $fb.f$i.l  $fb.f$i.e -side left;
    }
   incr i
   }
}

proc sliders { {sl  {{viewx 360} {viewy 360} {viewz 360}}} {w  {.sl}}  } {
   destroy $w
   toplevel $w
   foreach s $sl {
      set min 0
      set name [lindex $s 0]
      if {[llength $s] > 1} {set max  [lindex $s 1]} {set max 120; set min -12}
      frame $w.$name
      pack $w.$name -side left -expand y -fill y
      scale $w.$name.s -orient vertical -from $min -to $max -command "slidsend $name"
      pack $w.$name.s -side top -expand y -fill both
      bind $w.$name.s <ButtonRelease-1> slidsendupdate
      label $w.$name.l -text $name
      pack $w.$name.l -side bottom -expand n -fill x
      eval "bind $w.$name.l <ButtonRelease-1> {
	 global $w,$name,e
	 pack forget $w.$name.l
	 entry $w.$name.e -width 6 -textvar $w,$name,e
	 set $w,$name,e \[$w.$name.l cget -text\]
	 pack $w.$name.e -side bottom -expand n -fill x
	 bind $w.$name.e <Return> {
	     global $w,$name,e
	     eval $w.$name.l conf -text \$\{$w,$name,e\}
	     destroy $w.$name.e
	     pack $w.$name.l -side bottom -expand n -fill x
	     eval $w.$name.s conf -command \{ \"slidsend \$\{$w,$name,e\}\ \" \}
	 }
      }
      "

   }
}

proc slidsend { {n } {v }  } {
  send "$n $v"
}

proc slidsendupdate {  } {
   send update
}

proc stream_connect { {cg  {.cg}} {host  {localhost}} {port  {6543}}  } {
   global sock
   puts $cg,$host,$port
   if {$sock != -1} {
      log "Connect attempt while already connected: ignored" $cg
      set sock -1
      return
   }
   if {[catch {set sock [socket $host $port]}] !=0} {
      set sock -1
      log "Attempt to connect to $host $port failed.\n" $cg
      return
   }
   fconfigure $sock -blocking 0 -buffering line
   eval fileevent $sock readable "{
      global sock in
      if {\[eof \$sock\] != 0} {
	 log \"Connection closed.\\n\" $cg
	 close \$sock ; set sock -1
      } {
	 set in \[gets \$sock\]
	 log \\\[\$in\\\]\\n $cg
      }
   }"
}

proc streamui { {cg  {.cg}} {host  {localhost}} {port  {6543}}  } {
   catch {destroy $cg}
   toplevel $cg

   frame $cg.f1
   pack $cg.f1 -side top -expand n -fill x
   label $cg.f1.lh -text Host ; pack $cg.f1.lh -side left -expand n -fill none
   entry $cg.f1.eh -width 12 -textvar $cg.hostname ; pack $cg.f1.eh -side left -expand n -fill x
   label $cg.f1.lp -text Port; pack $cg.f1.lp -side left -expand n -fill none
   entry $cg.f1.ep -width 4 -textvar $cg.port ; pack $cg.f1.ep -side left -expand n -fill x
   uplevel #0 "set $cg.hostname $host; set $cg.port $port"
   frame $cg.f2
   pack $cg.f2 -side top -expand n -fill x
   button $cg.f2.bc -text Connect -command "
      stream_connect $cg \${$cg.hostname} \${$cg.port}
   "
   pack $cg.f2.bc -side left -expand n -fill none
   text $cg.th -width 32 -height 4 -font "courier 9"
   pack  $cg.th -side bottom -expand n -fill x
   entry $cg.el -textvar $cg.line
   pack $cg.el -side bottom -expand n -fill x
   bind $cg.el <Return> "
       global $cg.line
       send \${$cg.line}
       $cg.el selection range 0 end
   "
   frame $cg.f3
   pack $cg.f3 -side top -expand n -fill x
   button $cg.f3.bvx -text Rotx+ -command {
      global viewx
      incr viewx 10
      send "viewx $viewx" ; send update
   }
   pack $cg.f3.bvx -side left -expand n -fill none

}


proc tag_and { {tl }  } {
    global mc
    set r [$mc find withtag [lindex $tl 0]]
    foreach i [lrange $tl 1 end] {
       set r [listunion $r [$mc find withtag $i] ]
    }
    return $r
}

proc tagbbox { {tags  {}}  } {
   global mc
   foreach b [tag_and [eval list block $tags]] {
      cbbox [lindex [$mc itemcget $b -tags] 0]
   }
}

proc tclPkgSetup { {dir } {pkg } {version } {files }  } {
    global auto_index

    package provide $pkg $version
    foreach fileInfo $files {
	set f [lindex $fileInfo 0]
	set type [lindex $fileInfo 1]
	foreach cmd [lindex $fileInfo 2] {
	    if {[string equal $type "load"]} {
		set auto_index($cmd) [list load [file join $dir $f] $pkg]
	    } else {
		set auto_index($cmd) [list source [file join $dir $f]]
	    } 
	}
    }
}

proc tclPkgUnknown { {name } {version } {exact  {}}  } {
    global auto_path tcl_platform env

    if {![info exists auto_path]} {
	return
    }
    # Cache the auto_path, because it may change while we run through
    # the first set of pkgIndex.tcl files
    set old_path [set use_path $auto_path]
    while {[llength $use_path]} {
	set dir [lindex $use_path end]
	# we can't use glob in safe interps, so enclose the following
	# in a catch statement, where we get the pkgIndex files out
	# of the subdirectories
	catch {
	    foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
		set dir [file dirname $file]
		if {[file readable $file] && ![info exists procdDirs($dir)]} {
		    if {[catch {source $file} msg]} {
			tclLog "error reading package index file $file: $msg"
		    } else {
			set procdDirs($dir) 1
		    }
		}
	    }
	}
	set dir [lindex $use_path end]
	set file [file join $dir pkgIndex.tcl]
	# safe interps usually don't have "file readable", nor stderr channel
	if {([interp issafe] || [file readable $file]) &&  ![info exists procdDirs($dir)]} {
	    if {[catch {source $file} msg] && ![interp issafe]}  {
		tclLog "error reading package index file $file: $msg"
	    } else {
		set procdDirs($dir) 1
	    }
	}
	# On the Macintosh we also look in the resource fork 
	# of shared libraries
	# We can't use tclMacPkgSearch in safe interps because it uses glob
	if {(![interp issafe]) &&  [string equal $tcl_platform(platform) "macintosh"]} {
	    set dir [lindex $use_path end]
	    if {![info exists procdDirs($dir)]} {
		tclMacPkgSearch $dir
		set procdDirs($dir) 1
	    }
	    foreach x [glob -nocomplain [file join $dir *]] {
		if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
		    set dir $x
		    tclMacPkgSearch $dir
		    set procdDirs($dir) 1
		}
	    }
	}
	set use_path [lrange $use_path 0 end-1]
	if {[string compare $old_path $auto_path]} {
	    foreach dir $auto_path {
		lappend use_path $dir
	    }
	    set old_path $auto_path
	}
    }
}

proc tcl_endOfWord { {str } {start }  } {
    global tcl_nonwordchars tcl_wordchars
    if {[regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars"  [string range $str $start end] result]} {
	return [expr {[lindex $result 1] + $start}]
    }
    return -1
}

proc tcl_envTraceProc { {lo } {n1 } {n2 } {op }  } {

	global env
	set x $env($n2)
	set env($lo) $x
	set env([string toupper $lo]) $x
}

proc tcl_startOfNextWord { {str } {start }  } {
    global tcl_nonwordchars tcl_wordchars
    if {[regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars"  [string range $str $start end] result]} {
	return [expr {[lindex $result 1] + $start}]
    }
    return -1
}

proc tcl_startOfPreviousWord { {str } {start }  } {
    global tcl_nonwordchars tcl_wordchars
    if {[string equal $start end]} {
	set start [string length $str]
    }
    if {[regexp -indices  "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$"  [string range $str 0 [expr {$start - 1}]] result word]} {
	return [lindex $word 0]
    }
    return -1
}

proc tcl_wordBreakAfter { {str } {start }  } {
    global tcl_nonwordchars tcl_wordchars
    set str [string range $str $start end]
    if {[regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result]} {
	return [expr {[lindex $result 1] + $start}]
    }
    return -1
}

proc tcl_wordBreakBefore { {str } {start }  } {
    global tcl_nonwordchars tcl_wordchars
    if {[string equal $start end]} {
	set start [string length $str]
    }
    if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
	return [lindex $result 1]
    }
    return -1
}

proc tkFocusOK { {w }  } {
    set code [catch {$w cget -takefocus} value]
    if {($code == 0) && ($value != "")} {
	if {$value == 0} {
	    return 0
	} elseif {$value == 1} {
	    return [winfo viewable $w]
	} else {
	    set value [uplevel #0 $value $w]
	    if {$value != ""} {
		return $value
	    }
	}
    }
    if {![winfo viewable $w]} {
	return 0
    }
    set code [catch {$w cget -state} value]
    if {($code == 0) && ($value == "disabled")} {
	return 0
    }
    regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
}

proc tk_dialog { {w } {title } {text } {bitmap } {default } {args }  } {
    global tkPriv tcl_platform

    # Check that $default was properly given
    if {[string is int $default]} {
	if {$default >= [llength $args]} {
	    return -code error "default button index greater than number of buttons specified for tk_dialog"
	}
    } elseif {[string equal {} $default]} {
	set default -1
    } else {
	set default [lsearch -exact $args $default]
    }

    # 1. Create the top-level window and divide it into top
    # and bottom parts.

    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w $title
    wm iconname $w Dialog
    wm protocol $w WM_DELETE_WINDOW { }

    # Dialog boxes should be transient with respect to their parent,
    # so that they will always stay on top of their parent window.  However,
    # some window managers will create the window as withdrawn if the parent
    # window is withdrawn or iconified.  Combined with the grab we put on the
    # window, this can hang the entire application.  Therefore we only make
    # the dialog transient if the parent is viewable.
    #
    if { [winfo viewable [winfo toplevel [winfo parent $w]]] } {
	wm transient $w [winfo toplevel [winfo parent $w]]
    }    

    if {[string equal $tcl_platform(platform) "macintosh"]} {
	unsupported1 style $w dBoxProc
    }

    frame $w.bot
    frame $w.top
    if {[string equal $tcl_platform(platform) "unix"]} {
	$w.bot configure -relief raised -bd 1
	$w.top configure -relief raised -bd 1
    }
    pack $w.bot -side bottom -fill both
    pack $w.top -side top -fill both -expand 1

    # 2. Fill the top part with bitmap and message (use the option
    # database for -wraplength and -font so that they can be
    # overridden by the caller).

    option add *Dialog.msg.wrapLength 3i widgetDefault
    if {[string equal $tcl_platform(platform) "macintosh"]} {
	option add *Dialog.msg.font system widgetDefault
    } else {
	option add *Dialog.msg.font {Times 12} widgetDefault
    }

    label $w.msg -justify left -text $text
    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
    if {[string compare $bitmap ""]} {
	if {[string equal $tcl_platform(platform) "macintosh"] &&  [string equal $bitmap "error"]} {
	    set bitmap "stop"
	}
	label $w.bitmap -bitmap $bitmap
	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
    }

    # 3. Create a row of buttons at the bottom of the dialog.

    set i 0
    foreach but $args {
	button $w.button$i -text $but -command [list set tkPriv(button) $i]
	if {$i == $default} {
	    $w.button$i configure -default active
	} else {
	    $w.button$i configure -default normal
	}
	grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10
	grid columnconfigure $w.bot $i
	# We boost the size of some Mac buttons for l&f
	if {[string equal $tcl_platform(platform) "macintosh"]} {
	    set tmp [string tolower $but]
	    if {[string equal $tmp "ok"] || [string equal $tmp "cancel"]} {
		grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]
	    }
	}
	incr i
    }

    # 4. Create a binding for <Return> on the dialog if there is a
    # default button.

    if {$default >= 0} {
	bind $w <Return> "
	[list $w.button$default] configure -state active -relief sunken
	update idletasks
	after 100
	set tkPriv(button) $default
	"
    }

    # 5. Create a <Destroy> binding for the window that sets the
    # button variable to -1;  this is needed in case something happens
    # that destroys the window, such as its parent window being destroyed.

    bind $w <Destroy> {set tkPriv(button) -1}

    # 6. Withdraw the window, then update all the geometry information
    # so we know how big it wants to be, then center the window in the
    # display and de-iconify it.

    wm withdraw $w
    update idletasks
    set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2  - [winfo vrootx [winfo parent $w]]}]
    set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2  - [winfo vrooty [winfo parent $w]]}]
    wm geom $w +$x+$y
    wm deiconify $w

    # 7. Set a grab and claim the focus too.

    set oldFocus [focus]
    set oldGrab [grab current $w]
    if {[string compare $oldGrab ""]} {
	set grabStatus [grab status $oldGrab]
    }
    grab $w
    if {$default >= 0} {
	focus $w.button$default
    } else {
	focus $w
    }

    # 8. Wait for the user to respond, then restore the focus and
    # return the index of the selected button.  Restore the focus
    # before deleting the window, since otherwise the window manager
    # may take the focus away so we can't redirect it.  Finally,
    # restore any grab that was in effect.

    tkwait variable tkPriv(button)
    catch {focus $oldFocus}
    catch {
	# It's possible that the window has already been destroyed,
	# hence this "catch".  Delete the Destroy handler so that
	# tkPriv(button) doesn't get reset by it.

	bind $w <Destroy> {}
	destroy $w
    }
    if {[string compare $oldGrab ""]} {
      if {[string compare $grabStatus "global"]} {
	    grab $oldGrab
      } else {
	  grab -global $oldGrab
	}
    }
    return $tkPriv(button)
}

proc tk_focusFollowsMouse {  } {
    set old [bind all <Enter>]
    set script {
	if {("%d" == "NotifyAncestor") || ("%d" == "NotifyNonlinear")
		|| ("%d" == "NotifyInferior")} {
	    if [tkFocusOK %W] {
		focus %W
	    }
	}
    }
    if {$old != ""} {
	bind all <Enter> "$old; $script"
    } else {
	bind all <Enter> $script
    }
}

proc tk_focusNext { {w }  } {
    set cur $w
    while 1 {

	# Descend to just before the first child of the current widget.

	set parent $cur
	set children [winfo children $cur]
	set i -1

	# Look for the next sibling that isn't a top-level.

	while 1 {
	    incr i
	    if {$i < [llength $children]} {
		set cur [lindex $children $i]
		if {[winfo toplevel $cur] == $cur} {
		    continue
		} else {
		    break
		}
	    }

	    # No more siblings, so go to the current widget's parent.
	    # If it's a top-level, break out of the loop, otherwise
	    # look for its next sibling.

	    set cur $parent
	    if {[winfo toplevel $cur] == $cur} {
		break
	    }
	    set parent [winfo parent $parent]
	    set children [winfo children $parent]
	    set i [lsearch -exact $children $cur]
	}
	if {($cur == $w) || [tkFocusOK $cur]} {
	    return $cur
	}
    }
}

proc tk_focusPrev { {w }  } {
    set cur $w
    while 1 {

	# Collect information about the current window's position
	# among its siblings.  Also, if the window is a top-level,
	# then reposition to just after the last child of the window.
    
	if {[winfo toplevel $cur] == $cur}  {
	    set parent $cur
	    set children [winfo children $cur]
	    set i [llength $children]
	} else {
	    set parent [winfo parent $cur]
	    set children [winfo children $parent]
	    set i [lsearch -exact $children $cur]
	}

	# Go to the previous sibling, then descend to its last descendant
	# (highest in stacking order.  While doing this, ignore top-levels
	# and their descendants.  When we run out of descendants, go up
	# one level to the parent.

	while {$i > 0} {
	    incr i -1
	    set cur [lindex $children $i]
	    if {[winfo toplevel $cur] == $cur} {
		continue
	    }
	    set parent $cur
	    set children [winfo children $parent]
	    set i [llength $children]
	}
	set cur $parent
	if {($cur == $w) || [tkFocusOK $cur]} {
	    return $cur
	}
    }
}

proc to7seg {  } {
}

proc togglepinsel { {ids }  } {
    global mc
    foreach id $ids {
       if {[$mc itemcget $id -fill] != "green"} {
	  $mc itemco $id -fill green
	  $mc addtag selectedpin withtag $id
       } {
	  $mc itemco $id -fill darkblue
	  $mc dtag $id selectedpin
       }
    }
}

proc transfer { {blocks }  } {
   global togglepinson mc
   set togglepinson 1
   #puts *****$blocks
   foreach bl $blocks {
      #puts ****$bl,[block_get_pinnames $bl typeout]
      foreach p [block_get_pinnames $bl typeout] {
	 #puts ***[pin_get_wirenames $bl $p]
	 foreach w [pin_get_wirenames $bl $p] {
	    #puts **$bl,$p,$w
	    set a $bl.$p;
	    #puts a=$a
	    set o [wire_other $w $bl $p];
	    if {$togglepinson == 1} {
	       set fromp [eval tag_and \{$bl $p pin\}]
	       set top [eval tag_and \{[lindex $o 0] [lindex $o 1] pin\}]
	       togglepinsel $fromp
	       togglepinsel $top
	       update
	    }
	    #puts $fromp,$top
	    #puts o=$o
	    set b [lindex $o 0].[lindex $o 1];
	    #puts b=$b
	    global $a $b
	    eval set $b $\{$a\}
	    #puts -nonewline "transfering $a,$b --> "; eval puts ,$\{$a\}
	 }
      }
   };
   if {$togglepinson == 1} {
      $mc itemco pin  -fill darkblue
      $mc dtag all selectedpin
   }
   return ok
}

proc trig { {b } {p } {g  {y}}  } {
   global mc
   foreach w [pin_get_wirenames $b $p] {
       set nb [lindex [wire_other $w $b $p] 0];
       if {$g != "0"} {cbbox $nb ; update}
       uplevel #0 eval $\{[blockfunc $nb]\}
       if {$g != "0"} {after 50 "$mc del bbox ; update"}
       transfer $nb
   }
}

proc update_dbvar { {a }  } {
   global dbvar currententry dbcurrent dbcurrentvars
   foreach i $dbcurrentvars {
      if {[eval $$i] != {}} {
      }
   }
}

proc update_entry { {newentryvar  {dbcurrent}} {en  {}} {dbname  {dbvar}}  } {
   upvar #0 $newentryvar e $dbname db
   if {$en == {}} {global currententry; set en $currententry}
   set db [lreplace $db $en $en $e]
}

proc wire_coord { {name } {pin } {x } {y }  } {
    global mc
 #   puts $name,$pin,$x,$y;
    set w  [ listunion [$mc find withtag $pin] [listunion [$mc find withtag $name]  [$mc find withtag wire]] ] ;
 #    foreach i [ listunion [$mc find withtag wire] [$mc find withtag $name] ] {
 #
 #    }
     if {$w == {}} { return}
     foreach ww $w {
      set t [eval $mc itemcget $ww -tags]
 #     puts $ww,$t
      for {set i 3} {$i < [llength $t]} {set i [expr $i+2]} {
 #       puts $i
	if {[lindex $t $i] == $name} {
	   if {[lindex $t [expr $i+1]] == $pin} {
	      eval $mc coords $ww  "[ lreplace [$mc coords $ww] [expr $i-3] [expr $i+1-3] $x $y]" ; 
	   } 
	} ; 
     } ;
     }
}

proc wire_other { {wname } {block } {pin }  } {
    global mc; set r {}; 
    set t [$mc itemcget [eval "tag_and {$wname wire}"] -tags]; 
    if {[lindex $t 3] == $block && [lindex $t 4] == $pin}  {set r [lrange $t 5 6]};
    if {[lindex $t 5] == $block && [lindex $t 6] == $pin}  {set r [lrange $t 3 4]};
    return $r
}

proc wire_update { {name }  } {
    global mc
    foreach i [ listunion [$mc find withtag $name] [$mc find withtag pin ] ]  {eval  wire_coord $name [lindex [eval $mc itemcget $i -tags] 3]  [lrange [eval  $mc coords $i] 0 1]  }
}