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 bdo { {f } {t }  } { 
   global mc 
  switch $f  Eval {global mc;  uplevel #0 eval $\{[blockfunc $t]\}  }   Propagate {global mc;  run $t}  Transfer {global mc;  transfer $t}  Run {global mc; uplevel #0 eval $\{[blockfunc $t]\}; run $t}  Init {global mc; uplevel #0 eval $\{[blockfunc $t]_init\}; }
}

proc bdol { {l }  } { 
   foreach {f t} $l {
puts $f,$t
      switch $f   E {global mc;  uplevel #0 eval $\{[blockfunc $t]\}  }  P {global mc;  run $t}   T {global mc;  transfer $t}  R {global mc; uplevel #0 eval $\{[blockfunc $t]\}; run $t}  I {global mc; uplevel #0 eval $\{[blockfunc $t]_init\};}
   }
}

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 block_prev { {b } {d  {1000}}  } {
   set o {};
   foreach p [block_get_pinnames $b typein] {
      foreach op [otherpins $b $p] {
	 append o "{$b $p [lindex $op 0] [lindex $op 1]} "
      }
   }
   if {$d > 0} {foreach j $o {append o [block_prev [lindex $j 2]  [expr $d-1]]} }
   return $o
}

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
   bind $mc  <Button-2> {mnewmenu %X %Y %x %y} 
   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 7 command -label "Init" -command {global mc; set t "[$mc.pm entrycget 0 -label]" ;uplevel #0 eval $\{[blockfunc $t]_init\}; } 

#   $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 diarydate {  } {    
# insert the date as level 3 html heading    
   .di.t insert insert "<h3>[clock format [clock seconds]]</h3>\n"    
}

proc diarygen {  } {
   global diarynr
# find next page number    
   foreach n [lsort -incr -dict [glob {[d,D]iary*.htm*} ]] {    
puts $n    
   }    
   set n [lindex [lsort -incr -dict [glob {[d,D]iary*.htm*} ]] end]    
   if {$n == {}} return    
   set n [string range $n [expr [ string first iary $n] +4 ] [ expr [ string first "." $n] -1] ]    
#  set f [open $n w]    
   puts "diary[expr $n+1].htm"    
    
# generate page    
   set t {}  
   set f [open dihead.txt r]  
   while {[eof $f] == 0} {  
      eval append t \"[gets $f]\n\"   
   }  
   close $f  
   .di.t insert 0.0 $t  
   set diarynr  [expr $n+1];
}

proc diarysave {  } {
   global diarynr;
   set f [open "diary$diarynr.htm" "w"]
   puts $f [.di.t get 0.0 end]
   close $f
}

proc diarywin {  } {    
   global diarynr
   toplevel .di 
   text .di.t -width 60 -height 10 -font {{MS Sans Serif} 12} 
   pack .di.t -side bottom -expand y -fill both 
   button .di.gp -text "Generate page header" -command diarygen 
   button .di.date -text {Insert date heading} -command diarydate 
   button .di.save -text "Save Page" -command diarysave
   pack .di.gp -expand n -fill x -side left 
   pack .di.date -expand n -fill x -side left 
   pack .di.save -expand n -fill x -side left 
   diarydate 
   bind .di.t <F1> diarydate 
   bind .di.t <F2> { .di.t insert insert "<h4></h4>\n" }    
   bind .di.t <F8> { .di.t insert insert "<P>\n" }    
   bind .di.t <F9> { .di.t insert insert "<P>\n<pre>\n</pre>\n<P>\n" }    
   set diarynr 999
}

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 mnewinst { {p } {x } {y }  } {
global mc
#set x [$mc canvasx $x]
#set y [$mc canvasy $y]
   set tt [pro_args $p "{x $x} {y $y}"]
   puts $tt
   eval  "$tt"
}

proc mnewmenu { {X } {Y } {x } {y }  } {
global mc
set x [$mc canvasx $x]
set y [$mc canvasy $y]
   if {[llength [$mc find overlapping [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2] ] ] < 1}  {
      set pp [$mc find overlapping [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2] ]
# puts $x,$y,$pp,
      catch {destroy $mc.m}; menu $mc.m; $mc.m del 0 end
      foreach i [lsort -dict [info proc new*]] {$mc.m add command -label [string range $i 3 end] -command "mnewinst $i $x $y"}
      tk_popup $mc.m $X $Y
   }
}

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  {}} {x  {100}} {y  {120}}  } {
   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 $x + 80 * $i] [expr $y + 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  {display}} {x  {0}} {y  {0}}  } {
   global mc $name.bfunc
   set xx $x; set yy $y
   newblock $name [expr $x+10] [expr $y+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 $xx+$x*10+22] [expr $yy+$y*10+22] [expr $xx+$x*10+22 +6] [expr $yy+$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  {}} {x  {0}} {y  {0}}  } {
   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 $x $y $width $height {} out $tags
   blockclear $name
   set lc [string tolower $name]
   entry $mc.$lc -width 5 -textvar $name.out
   $mc create window [expr $x+3] [expr $y+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  {}} {x  {0}} {y  {0}}  } {
   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 $x $y $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 [expr 4+$x] [expr 4+$y]  -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 -nonewline $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 pro_args { {p } {ar }  } {
   set o {}
   set c 0; set maxc -1
   foreach a [info args $p] {
      set m {};
      foreach j $ar {
         if [string match $a [lindex $j 0]] { 
            set m 1 
            set arr [lindex $j 1]
            set maxc $c
         }
      }
      if {$m == {}} {
         if { [info default $p $a b] == 1} {
	      append o " [list $b]" } {
	      append o  " {}"
         }
      } {
         append o " [list $arr]"
      }
      incr c
   }
   set o "$p [lrange $o 0 $maxc]"
   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 nnn
   set nnn $n
   uplevel #0 {
      set ooo {}
      foreach i [lsort -dict [info procs]] {
	 if {[lsearch $defaultprocs $i] == -1 &&
		 [string index $i 0] != "\$"  &&
		 ![string match tcl* $i] &&
                                 ![string match tk* $i] } {
#              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_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_procs_bak3 { {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_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 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_procvanilla {  } {
global defaultprocs
puts "This routine should be called when only the startup\m"
puts "procedures are present to make the file 'defaultprocs.tcl'"
	set defaultprocs {}
	foreach i [info procs] {
		if {[string match {tk*} $i] == 1 || 
		  [string match {tcl*} $i] == 1} {
			append defaultprocs "$i "
		}
	}
	set f [open defaultprocs.tcl w]
	puts $f $defaultprocs
	close $f
}

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 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]  }
}