1# Copyright (C) 1987-2015 by Jeffery P. Hansen 2# 3# This program is free software; you can redistribute it and/or modify 4# it under the terms of the GNU General Public License as published by 5# the Free Software Foundation; either version 2 of the License, or 6# (at your option) any later version. 7# 8# This program is distributed in the hope that it will be useful, 9# but WITHOUT ANY WARRANTY; without even the implied warranty of 10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11# GNU General Public License for more details. 12# 13# You should have received a copy of the GNU General Public License along 14# with this program; if not, write to the Free Software Foundation, Inc., 15# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16# 17# Last edit by hansen on Sun Feb 1 17:56:08 2009 18# 19 20######################################################################## 21# 22# Function summary: 23# mr Get a message and apply [rescale] to it. 24# ul Underline position generator. 25# offsetgeometry Generate geometry string relative to another window. 26# okcancel Create an OK/Cancel bar for dialogs. 27# replaceExtension Replace the extension of a file name. 28# toolbutton Button for a toolbar 29# ldelete Remove a named item from a list. 30# lsubtract Do a list "set subtraction" option 31# lpop Pop an item from the end of a list 32# lscan Partition elements of a list 33# assoc Find an item from a list of pairs and return value. 34# assocn Generalized version of assoc 35# assocg Find an item from a list of lists and return indexed list. 36# assocset Find an item from a list of pairs and change its value 37# assocsetc Find an item from a list of pairs and change its value (create if necessary) 38# parseargs Parse an argument list. 39# viewFile View the contents of a file in a separate window. 40# min Minimum value 41# max Maximum value 42# ceil Ceiling function 43# floor Floor function 44# labelframe Labled groove frame 45# checkframe Labled groove frame with checkbutton label 46# radioframe Labled groove frame with radiobutton label 47# windowframe Labled groove frame with arbitrary window label 48# gifI Get a gif image from a file or from cache 49# start_splash Display the "splash" window 50# end_splash End the "splash" window. 51# yesno Generic yes/no dialog box 52# frb_trace Flat radio button variable change notifier 53# frb_setMouseOverBackground Set the mouseover background for flat radio buttons. 54# frb_seeB1press See a B1 mouse press on a flat radio button. 55# flatradiobutton Create a flat radio button. 56# paneDecoration Create the decoration for a resizable pane slider. 57# dialogImage Create the image bar for a dialog box. 58# gettoplevel Get the top level window from a path 59# Option:: Options management class 60# sfix Fix any special characters in a string befor saving it. 61# dialogLoad Load new option variables from the dialog box 62# dialogSave Save option variables to the dialog box 63# writePreferences Write current option settings to prefernces file. 64# new Declare a new option. 65# restoreDefaults Restore defaults of all options or of a class of options 66# TimeCheck Procedure timing check 67# begin Begin a timer 68# end End a timer 69# unqiueName Generate a unique name. 70# hexEntrySetup Setup for hex only entry widgets. 71# encodeBits Encode list of numbers into a single number 72# incdecEntry Numeric entry with inc/dec buttons 73# chooseInterval Choose an interval to use for a range 74# colortree Set background color of a window and all its children 75# packPad Add font-size scaled padding to the top and bottom of a frame. 76# linkVars Link two variables 77# 78 79proc mr {tag} { 80 return [rescale [m $tag]] 81} 82 83proc getFontScale {fontName baseEmSize} { 84 return [expr [font measure $fontName "M"] / ($baseEmSize+0.0)] 85} 86 87proc colortree {w args} { 88 if {[lindex $args 0] == "-list"} { 89 set args [lindex $args 1] 90 } 91 92 foreach {sw val} $args { 93 catch { $w configure $sw $val } 94 } 95 96 foreach cw [winfo children $w] { 97 colortree $cw -list $args 98 } 99} 100 101proc dobell args { 102 bell 103} 104 105proc ul {n} { 106 global lang 107 108 if { $lang == "en" } { 109 return $n 110 } else { 111 return -1 112 } 113} 114 115proc safeeval {bad cmd args} { 116 set L {} 117 set skip 0 118 foreach p $args { 119 if {[lsearch -exact $bad $p] >= 0} { 120 set skip 1 121 } elseif {$skip == 0} { 122 lappend L $p 123 } else { 124 set skip 0 125 } 126 } 127 eval $cmd $L 128} 129 130 131# offsetgeometry win dx dy 132# 133# Return a geomtry string with the specified offset from the specified window. 134# 135# 136proc offsetgeometry { win dx dy } { 137 set g [wm geometry $win] 138 set x [string range $g [expr [string first "+" $g] + 1] end] 139 set p [string first "+" $x] 140 set y [string range $x [expr $p + 1] end] 141 set x [string range $x 0 [expr $p - 1]] 142 return +[expr $x + $dx ]+[expr $y + $dy] 143} 144 145proc okcancel {w args} { 146 frame $w 147 148 149 set cancelcommand "destroy $w" 150 set okcommand "destroy $w" 151 set oktext [m b.ok] 152 set canceltext [m b.cancel] 153 set bd [option get $w TkgDialog.borderWidth {}] 154 set relief [option get $w TkgDialog.relief {}] 155 156 parseargs $args {-oktext -canceltext -okcommand -cancelcommand -bd} 157 158 $w configure -relief $relief -bd $bd 159 button $w.ok -text $oktext -command $okcommand 160 button $w.cancel -text $canceltext -command $cancelcommand 161 162 pack $w.cancel -side right -padx 5 -pady 5 163 pack $w.ok -side right -padx 5 -pady 5 164} 165 166# 167# Replace the extension of name with ext. "ext" should 168# include the '.' character if it is desired. 169# 170proc replaceExtension {name ext} { 171 set p [string last "." $name ] 172 if { $p >= 0 } { 173 set name [string range $name 0 [expr $p - 1]] 174 } 175 return "$name$ext" 176} 177 178# 179# Remove all elements from d from l 180# 181proc lsubtract {l d} { 182 foreach x $d { 183 set l [ldelete $l $x] 184 } 185 return $l 186} 187 188# 189# remove i from list l 190# 191proc ldelete {l i} { 192 set p [lsearch $l $i] 193 if { $p >= 0 } { 194 return [lreplace $l $p $p] 195 } { 196 return $l 197 } 198} 199 200# 201# Given a list of the form {{t1 v1} {t2 v2} ... } 202# return the value from the pair having the tag 'tag'. 203# 204proc assoc {tag l} { 205 set value "" 206 catch { 207 foreach p $l { 208 if {[lindex $p 0] == $tag } { 209 set value [lindex $p 1] 210 break 211 } 212 } 213 } 214 return $value 215} 216 217# 218# Given a list of the form {{a1 b1 ...} {a2 b2 ...} ... } return 219# the value for which l matches the nth (starting at zero) item 220# in a sub-list 221# 222proc assocn {tag n l} { 223 set value {} 224 catch { 225 foreach p $l { 226# puts "testing string equal [lindex $p $n] $tag" 227 if {[string equal [lindex $p $n] $tag]} { 228 set value $p 229 break 230 } 231 } 232 } 233 return $value 234} 235 236proc assocg {tag l} { 237 set value "" 238 catch { 239 foreach p $l { 240 if {[lindex $p 0] == $tag } { 241 set value $p 242 break 243 } 244 } 245 } 246 return $value 247} 248 249proc assocset {tag l newV} { 250 set value "" 251 252 set L {} 253 254 foreach p $l { 255 if {[lindex $p 0] == $tag } { 256 lappend L [list $tag $newV] 257 } else { 258 lappend L $p 259 } 260 } 261 return $L 262} 263 264proc assocsetc {tag l newV} { 265 set value "" 266 267 set L {} 268 set found 0 269 270 foreach p $l { 271 if {[lindex $p 0] == $tag } { 272 lappend L [list $tag $newV] 273 set found 1 274 } else { 275 lappend L $p 276 } 277 } 278 279 if {!$found} { 280 lappend L [list $tag $newV] 281 } 282 283 return $L 284} 285 286############################################################################## 287# 288# Parse an argument list 289# 290proc parseargs {argv nameset args} { 291 set R {} 292 set is_partial 0 293 set index "" 294 295 if {[lsearch $args "-partial"] >= 0} { 296 set is_partial 1 297 } 298 set array [lsearch $args "-array"] 299 if { $array >= 0} { 300 set index [lindex $args [expr $array+1]] 301 } 302 303 while { [llength $argv] > 0 } { 304 305 set sw [lindex $argv 0] 306 307 if { [lsearch -exact $nameset $sw] >= 0 } { 308 set vname [string range $sw 1 end] 309 set val [lindex $argv 1] 310 set argv [lrange $argv 2 end] 311 312 if { $index == "" } { 313 upvar $vname local_$vname 314 } else { 315 upvar ${vname}($index) local_$vname 316 } 317 set local_$vname $val 318 } elseif { $is_partial } { 319 lappend R $sw 320 set argv [lrange $argv 1 end] 321 } else { 322 error "bad option \"$sw\" must be one of: $nameset" 323 return 324 } 325 326 } 327 328 return $R 329} 330 331proc viewFile {label file} { 332 if {[catch { set f [open $file]}]} { 333 errmsg [format [m err.viewfile] $file] 334 return 335 } 336 337 338 set w .vfwin 339 set i 0 340 while { [catch { toplevel $w$i}] } { 341 incr i 342 } 343 set w $w$i 344 345 wm title $w $label 346 347 frame $w.main 348 text $w.main.text -yscrollcommand "$w.main.vb set" -xscrollcommand "$w.main.hb set" 349 scrollbar $w.main.vb -command "$w.main.text yview" 350 scrollbar $w.main.hb -orient horizontal -command "$w.main.text xview" 351 352 grid rowconfigure $w.main 0 -weight 1 353 grid columnconfigure $w.main 0 -weight 1 354 grid $w.main.text -row 0 -column 0 -sticky nsew 355 grid $w.main.vb -row 0 -column 1 -sticky ns 356 grid $w.main.hb -row 1 -column 0 -sticky ew 357 358 button $w.dismiss -text [m b.dismiss] -command "destroy $w" 359 360 pack $w.main -fill both -expand 1 361 pack $w.dismiss -fill x 362 363 catch { 364 $w.main.text insert end [read $f] 365 close $f 366 } 367 $w.main.text configure -state disabled 368} 369 370proc ceil {n} { 371 set n [format %f $n] 372 set d [string first "." $n] 373 if { $d < 0 } { 374 return $n 375 } 376 if { [string trim [string range $n [expr $d+1] end] "0"] == "" } { 377 return [expr [string range $n 0 $d] + 0.0] 378 } else { 379 return [expr [string range $n 0 $d] + 1.0] 380 } 381} 382 383proc floor {n} { 384 set n [format %f $n] 385 set d [string first "." $n] 386 if { $d < 0 } { 387 return $n 388 } 389 return [expr [string range $n 0 $d] + 0.0] 390} 391 392proc min args { 393 if {[llength $args] == 0 } { return 0 } 394 395 set m [lindex $args 0] 396 foreach v $args { 397 if {$v < $m} { set m $v } 398 } 399 return $m 400} 401 402proc max args { 403 if {[llength $args] == 0 } { return 0 } 404 405 set m [lindex $args 0] 406 foreach v $args { 407 if {$v > $m} { set m $v } 408 } 409 return $m 410} 411 412proc vmin {v} { 413 if {[llength $v] == 0} { 414 return "" 415 } 416 417 set M [lindex $v 0] 418 foreach e $v { 419 if { $e < $M } { set M $e } 420 } 421 return $M 422} 423 424proc vmax {v} { 425 if {[llength $v] == 0} { 426 return "" 427 } 428 429 set M [lindex $v 0] 430 foreach e $v { 431 if { $e > $M } { set M $e } 432 } 433 return $M 434} 435 436proc imin {args} { return [vmin $args]} 437proc imax {args} { return [vmax $args]} 438 439 440# 441# Create a labeled grooved frame. 442# 443proc labelframe {w lab args} { 444 frame $w 445 446 set borderwidth [option get $w LabelFrame.borderWidth {}] 447 set relief [option get $w LabelFrame.relief {}] 448 449 parseargs $args {-borderwidth -bd -relief} 450 if {[info exists bd]} {set borderwidth $bd} 451 452 $w configure -bd $borderwidth -relief $relief 453 454# eval "$w configure $args" 455# frame $w.labelframe_pad -height 10 456# pack $w.labelframe_pad 457 label ${w}_label -text $lab 458 place ${w}_label -in $w -x 10 -y -10 459} 460 461# 462# Create a labeled grooved frame with a checkbutton 463# 464proc checkframe {w lab args} { 465 466 frame $w 467 468 set borderwidth [option get $w LabelFrame.borderWidth {}] 469 set relief [option get $w LabelFrame.relief {}] 470 471 set variable "checkframe$w" 472 set command "" 473 parseargs $args {-bd -relief -variable -command} 474 if {[info exists bd]} {set borderwidth $bd} 475 476 $w configure -borderwidth $borderwidth -relief $relief 477 478 checkbutton ${w}_label -text $lab -variable $variable -command $command 479 place ${w}_label -in $w -x 10 -y -10 480} 481 482# 483# Create a labeled grooved frame with a radiobutton 484# 485proc radioframe {w lab args} { 486 frame $w 487 488 set borderwidth [option get $w LabelFrame.borderWidth {}] 489 set relief [option get $w LabelFrame.relief {}] 490 491 set variable "checkframe$w" 492 set value "0" 493 set command "" 494 parseargs $args {-bd -relief -variable -value -command} 495 if {[info exists bd]} {set borderwidth $bd} 496 497 $w configure -borderwidth $borderwidth -relief $relief 498 499 radiobutton ${w}_label -text $lab -variable $variable -value $value -command $command 500 place ${w}_label -in $w -x 10 -y -10 501} 502 503# 504# Create a grooved frame with another window as a label 505# 506proc windowframe {w lw args} { 507 508 frame $w 509 510 set borderwidth [option get $w LabelFrame.borderWidth {}] 511 set relief [option get $w LabelFrame.relief {}] 512 set dy 0 513 parseargs $args {-bd -relief -dy} 514 if {[info exists bd]} {set borderwidth $bd} 515 516 $w configure -borderwidth $borderwidth -relief $relief 517 518 place $lw -in $w -x 10 -y [expr -10 + $dy] 519 raise $lw 520} 521 522# 523# Create an image radiobutton with accompaning text and explaination. 524# 525proc imageRadioButton {w args} { 526 set onimage "" 527 set offimage "" 528 set variable "" 529 set label "" 530 set description "" 531 set value "" 532 set wraplength 200 533 534 parseargs $args {-onimage -offimage -variable -value -label -description -wraplength} 535 536 frame $w 537 radiobutton $w.button -image $offimage -selectimage $onimage -variable $variable -value $value -indicatoron 0 538 label $w.header -text $label -font dialogBigExpFont 539 label $w.details -text $description -justify left -wraplength $wraplength -font dialogExpFont 540 frame $w.pad -width 4 541 542 pack $w.button -side left -anchor nw 543 pack $w.pad -side left 544 pack $w.header -anchor nw 545 pack $w.details -anchor nw -pady 2 546} 547 548# 549# Create an image object from a .gif file name. 550# 551proc gifI {f} { 552 global bd 553 global gifTable 554 555 if { [string index $f 0] != "/" } { 556 set f "$bd/$f" 557 } 558 559 # 560 # Try to get the image from the image table first. If we don't find it, 561 # create the image and save it in the table. 562 # 563 catch { 564 return $gifTable($f) 565 } 566 567 if { [ catch { set gifTable($f) [image create photo -file $f] }]} { 568 set gifTable($f) [image create photo -file "$bd/broken-img.gif" ] 569 } 570 571 return $gifTable($f) 572} 573 574 575# 576# Post the splash window. 577# 578proc start_splash {} { 579 global sd bd splash_start_time tkg_doSplash 580 581 if { ! $tkg_doSplash} { return } 582 583 if {[catch { set splash_start_time [clock clicks -milliseconds] }]} { 584 set splash_start_time "rawdelay" 585 } 586 587 if {[catch { wm state . withdrawn }]} { 588 wm iconify . 589 } 590 591 update 592 593 toplevel .splash -class Splash 594 label .splash.logo -image [gifI "$bd/biggatelogo.gif"] 595 pack .splash.logo 596 wm overrideredirect .splash 1 597 wm transient .splash "" 598 599 set iwidth [image width [.splash.logo cget -image]] 600 set iheight [image height [.splash.logo cget -image]] 601 602 set x [expr ([winfo screenwidth .] - $iwidth)/2 ] 603 set y [expr ([winfo screenheight .] - $iheight)/2 ] 604 wm geometry .splash +${x}+${y} 605 update 606} 607 608# 609# Remove the splash window 610# 611proc end_splash {} { 612 global bd splash_start_time tkg_doSplash tkg_splashWait 613 614 if { ! $tkg_doSplash} { return } 615 616 if { $splash_start_time == "rawdelay" } { 617 set time_to_go 1000 618 } else { 619 set time_to_go [expr $tkg_splashWait - ([clock clicks -milliseconds] - $splash_start_time)] 620 } 621 622 if { $time_to_go < 1 } { set time_to_go 1 } 623 624 after $time_to_go { 625 update 626 destroy .splash 627 wm deiconify . 628 update 629 } 630} 631 632proc yesno {msg} { 633 return [tk_messageBox -default no -type yesno -icon warning -message $msg] 634} 635 636# 637# Respond to a variable change in a flatradiobutton 638# 639proc frb_trace {w v args} { 640 catch { 641 global flatradiobutton_details 642 set variable [assoc variable $flatradiobutton_details($w)] 643 global $variable 644 645 set v [set $variable] 646 647 set bg [assoc bg $flatradiobutton_details($w)] 648 set value [assoc value $flatradiobutton_details($w)] 649 650 if {$v == $value } { 651 $w configure -relief sunken 652 } else { 653 $w configure -relief flat 654 $w configure -bg $bg 655 } 656 } 657} 658 659# 660# Set brackground of flat radio button based on mouseover state 661# 662proc frb_setMouseOverBackground {w ismouseover} { 663 global flatradiobutton_details 664 665 set bg [assoc bg $flatradiobutton_details($w)] 666 set activebackground [assoc activebackground $flatradiobutton_details($w)] 667 set selectcolor [assoc selectcolor $flatradiobutton_details($w)] 668 set value [assoc value $flatradiobutton_details($w)] 669 set variable [assoc variable $flatradiobutton_details($w)] 670 global $variable 671 672 set v [set $variable] 673 674 if { $ismouseover } { 675 if { $v == $value } { 676 $w configure -bg $selectcolor -activebackground $selectcolor -relief raised 677 } else { 678 $w configure -bg $activebackground -activebackground $activebackground -relief raised 679 } 680 } else { 681 if { $v == $value } { 682 $w configure -bg $selectcolor -relief sunken 683 } else { 684 $w configure -bg $bg -relief flat 685 } 686 } 687} 688 689proc frb_seeB1press {w} { 690 global flatradiobutton_details 691 692 set command [assoc command $flatradiobutton_details($w)] 693 set value [assoc value $flatradiobutton_details($w)] 694 set var [assoc variable $flatradiobutton_details($w)] 695 696 global $var 697 set $var $value 698 699 frb_setMouseOverBackground $w 1 700 701 eval $command 702} 703 704# 705# tcl/tk 8.3 and earlier does not support flat radio buttons with "-indicatoron false". 706# This is a limited implementation and only supports the features we need for the mode 707# selectors. 708# 709proc flatradiobutton {w args} { 710 global flatradiobutton_details 711 712 set image "" 713 set variable "" 714 set value "" 715 set command "" 716 set selectcolor "\#aaaacc" 717 set activebackground [option get . FlatRadioButton.activeBackground {}] 718 set bg [option get . FlatRadioButton.background {}] 719 720 parseargs $args {-image -variable -value -command -selectcolor -bg -activebackground} 721 722 723 set flatradiobutton_details($w) {} 724 lappend flatradiobutton_details($w) [list image $image] 725 lappend flatradiobutton_details($w) [list variable $variable] 726 lappend flatradiobutton_details($w) [list value $value] 727 lappend flatradiobutton_details($w) [list command $command] 728 lappend flatradiobutton_details($w) [list selectcolor $selectcolor] 729 lappend flatradiobutton_details($w) [list bg $bg] 730 lappend flatradiobutton_details($w) [list activebackground $activebackground] 731 732 global $variable 733 734 if {[catch {button $w -takefocus 0 -image $image -bd 1 -relief flat -overrelief raised}]} { 735 button $w -takefocus 0 -image $image -bd 1 -relief flat 736 } 737 738 set v [set $variable] 739 if {$v == $value } { 740 $w configure -relief sunken 741 $w configure -bg $selectcolor 742 } else { 743 $w configure -relief flat 744 } 745 746 trace variable $variable w "frb_trace $w" 747 bind $w <Destroy> "trace vdelete $variable w \"frb_trace $w\"" 748 bind $w <ButtonPress-1> "frb_seeB1press $w" 749 750 bind $w <Enter> "+ frb_setMouseOverBackground %W 1" 751 bind $w <Leave> "+ frb_setMouseOverBackground %W 0" 752} 753 754proc paneDecoration {w args} { 755 set orient vertical 756 parseargs $args {-orient} 757 758 if { $orient == "vertical" } { 759 set width 50 760 set height 2 761 } else { 762 set width 2 763 set height 50 764 } 765 766 frame $w.v1 -bd 1 -relief raised -width $width -height $height 767 frame $w.v2 -bd 1 -relief raised -width $width -height $height 768 frame $w.v3 -bd 1 -relief raised -width $width -height $height 769 770 if { $orient == "vertical" } { 771 pack $w.v1 772 pack $w.v2 773 pack $w.v3 774 } else { 775 pack $w.v1 -side left 776 pack $w.v2 -side left 777 pack $w.v3 -side left 778 } 779 780} 781 782proc dialogImage {w args} { 783 global tkg_showDialogImage 784 set fontScale [getFontScale dialogExpFont 10] 785 786 set image "" 787 set caption "" 788 set font dialogCapFont 789 set bd 0 790 set width [rescale [m @opt.sidebar.width]] 791 set height 0 792 set relief flat 793 set explaination "" 794 set labelheight [rescale 50] 795 set imgbd 0 796 set force 0 797 set imgrelief flat 798 set expfont dialogExpFont 799 800 parseargs $args {-image -caption -font -bd -imgbd -imgrelief -width -relief -explaination -labelheight -force -expfont} 801 802 if {!$tkg_showDialogImage && !$force} { 803 frame $w 804 return 805 } 806 807 set iheight [image height $image] 808 set iwidth [image width $image] 809 810 set height [expr $iheight + 100 ] 811 812 frame $w -bd $bd -relief $relief -width $width -height $height 813 814 label $w.cap -text $caption -font $font 815 label $w.img -image $image -bd $imgbd -relief $imgrelief 816 # label $w.exp -text $explaination -justify left -wraplength [expr 155 * $fontScale] -font $expfont 817 label $w.exp -text $explaination -justify left -wraplength [expr $width - 10] -font $expfont 818 819 set x [expr $width/2] 820 set y [expr $labelheight/2] 821 822 place $w.cap -x $x -y $y -anchor center 823 set y [expr $y + $iheight/2 + $labelheight] 824 place $w.img -x $x -y $y -anchor center 825 set y [expr $y + [image height $image]/2 + 30] 826 place $w.exp -x $x -y $y -anchor n 827 828 set bottom [expr [winfo reqheight $w.exp] + $y + 15] 829 830 if { $bottom > $height } { 831 $w configure -height $bottom 832 } 833 834} 835 836# 837# Validate function for bit size selector. All chars must be digits, and there 838# is a 3 char maximum. 839# 840proc bsValidate {w act cur c newv} { 841# puts "bsValidate $w <$act> <$cur> <$c> <$newv>" 842# if {[string length $newv] == 0} { return 0 } 843 if {$act == 1} { 844 if {[string length $cur] > 2} { 845 return 0 846 } 847 return [string is digit $c] 848 } 849 850 return 1 851} 852 853proc bitsizeselector {w args} { 854 855 set entry 1 856 857 parseargs $args {-variable -value -width -entry -takefocus} 858 859 set argv {} 860 if {[info exists variable]} { lappend argv -variable $variable } 861 if {[info exists value]} { lappend argv -value $value } 862 if {[info exists width]} { lappend argv -width $width } 863 if {[info exists entry]} { lappend argv -entry $entry } 864 if {[info exists takefocus]} { lappend argv -takefocus $takefocus } 865 866 eval "Dropbox::new $w $argv -entry $entry -validatecommand bsValidate" 867 for { set i 1} { $i <= 32 } { incr i } { 868 Dropbox::itemadd $w $i 869 } 870} 871 872namespace eval TimeCheck { 873 variable timer 874 875 proc begin {e} { 876 variable timer 877 878 set timer($e) [clock clicks -milliseconds] 879 puts "begin $e" 880 } 881 proc end {e} { 882 variable timer 883 884 set t [clock clicks -milliseconds] 885 set dt [expr ($t - $timer($e) + 0.0)/1000.0] 886 puts "end $e $dt" 887 } 888} 889 890# 891# Fix name so as not to have special characters and make sure it does 892# not conflict with names in l. 893# 894proc unqiueName {name l} { 895 puts "unqiueName $name" 896 return $name 897} 898 899# 900# Setup for hex only entry widgets 901# 902proc hexEntrySetup {} { 903 bind HexEntry <Delete> { continue } 904 bind HexEntry <BackSpace> { continue } 905 bind HexEntry <Control-KeyPress> { continue } 906 bind HexEntry <KeyPress> { 907 set c [string tolower %A] 908 909 if { $c == "" } { continue } 910 911 if { [string first $c "0123456789abcdef"] < 0 } { break } 912 913 914 if {[%W selection present]} { 915 %W delete sel.first sel.last 916 } else { 917 %W delete insert 918 } 919 set L [string length [%W get]] 920 921 if { $L >= 8 } { break } 922 923 # 924 # Temporarily disable the "HexEntry" event handler and send a regular 925 # event to insert the character. 926 # 927 bindtags %W [lrange [bindtags %W] 1 end] 928 event generate %W <KeyPress> -keysym $c 929 bindtags %W [concat [list HexEntry] [bindtags %W]] 930 931 break 932 } 933} 934 935# 936# Setup for number only entry widgets 937# 938proc numEntrySetup {} { 939 bind NumEntry <Delete> { continue } 940 bind NumEntry <BackSpace> { continue } 941 bind NumEntry <Control-KeyPress> { continue } 942 bind NumEntry <KeyPress> { 943 set c [string tolower %A] 944 945 if { $c == "" } { continue } 946 947 if { [string first $c "0123456789"] < 0 } { break } 948 949 if {[%W selection present]} { 950 %W delete sel.first sel.last 951 } else { 952 %W delete insert 953 } 954 set L [string length [%W get]] 955 956 if { $L >= 8 } { break } 957 958 # 959 # Temporarily disable the "NumEntry" event handler and send a regular 960 # event to insert the character. 961 # 962 bindtags %W [lrange [bindtags %W] 1 end] 963 event generate %W <KeyPress> -keysym $c 964 bindtags %W [concat [list NumEntry] [bindtags %W]] 965 966 break 967 } 968} 969 970 971# 972# Setup for number only entry widgets 973# 974proc floatEntrySetup {} { 975 bind FloatEntry <Delete> { continue } 976 bind FloatEntry <BackSpace> { continue } 977 bind FloatEntry <Control-KeyPress> { continue } 978 bind FloatEntry <KeyPress> { 979 set c [string tolower %A] 980 981 if { $c == "" } { continue } 982 983 if { [string first $c "0123456789."] < 0 } { break } 984 985 if {[%W selection present]} { 986 %W delete sel.first sel.last 987 } else { 988 %W delete insert 989 } 990 set L [string length [%W get]] 991 992 if { $L >= 8 } { break } 993 994 # 995 # Temporarily disable the "FloatEntry" event handler and send a regular 996 # event to insert the character. 997 # 998 bindtags %W [lrange [bindtags %W] 1 end] 999 if { $c == "." } { set c period } 1000 event generate %W <KeyPress> -keysym $c 1001 bindtags %W [concat [list FloatEntry] [bindtags %W]] 1002 1003 break 1004 } 1005} 1006 1007############################################################################# 1008# 1009# Helping function for shellWindow. 1010# 1011############################################################################# 1012proc shellExec {args} { 1013 global shellCommand 1014 1015 set w .shell_win 1016 1017 $w.text insert end "${shellCommand}\n" cmd 1018 $w.text tag configure cmd -foreground blue 1019 1020 if {[catch { set result [namespace eval :: "$shellCommand"] } err]} { 1021 $w.text insert end "${err}\n" err 1022 $w.text tag configure err -foreground red 1023 } else { 1024 $w.text insert end "${result}\n" result 1025 $w.text tag configure result -foreground black 1026 } 1027 1028 $w.text see end 1029 1030 set shellCommand "" 1031} 1032 1033############################################################################# 1034# 1035# Create a shell window in which we can type an execute tcl commands for 1036# debugging purposes. 1037# 1038############################################################################# 1039proc shellWindow {} { 1040 set w .shell_win 1041 1042 if {[catch {toplevel $w}]} { 1043 raise $w 1044 return 1045 } 1046 1047 wm title $w "TKGate: Tcl Shell" 1048 1049 button $w.dismiss -text Dismiss -command "destroy $w" 1050 pack $w.dismiss -side bottom -anchor e -padx 5 -pady 5 1051 1052 frame $w.b 1053 pack $w.b -side bottom -fill x -expand 1 1054 1055 label $w.b.l -text "Command: " 1056 pack $w.b.l -side left -padx 5 -pady 5 1057 1058 entry $w.b.e -textvariable shellCommand 1059 pack $w.b.e -fill x -padx 5 -pady 5 -expand 1 1060 1061 bind $w.b.e <Return> shellExec 1062 1063 focus $w.b.e 1064 1065 text $w.text -bd 2 -relief sunken -width 60 -height 20 -yscrollcommand "$w.vb set" 1066 pack $w.text -padx 5 -pady 5 -fill both -expand 1 -side left 1067 1068 scrollbar $w.vb -orient vertical -command "$w.text yview" 1069 pack $w.vb -side right -padx 5 -pady 5 -fill y -expand 1 1070} 1071 1072############################################################################# 1073# 1074# Perform a standard wait for a dialog box. We update all events, set 1075# a grab on the dialog box and wait for the dialog box to be destroyed. 1076# We then release the grab and call gat_syncInterface to cause any 1077# internal circuit changes to be synchronized with tcl/tk elements. 1078# 1079############################################################################# 1080set dialogWaitStack {} 1081proc dialogWait {w args} { 1082 global dialogWaitStack 1083 set dosync 1 1084 1085 parseargs $args {-dosync} 1086 1087 # 1088 # Put window on stack 1089 # 1090 lappend dialogWaitStack $w 1091 1092 update 1093 grab set $w 1094 1095 tkwait window $w 1096 1097 if {[llength $dialogWaitStack] > 1 } { 1098 set dialogWaitStack [lrange $dialogWaitStack 0 end-1] 1099 set lastW [lindex $dialogWaitStack [expr [llength $dialogWaitStack]-1]] 1100 catch { grab release $w } 1101 grab set $lastW 1102 } else { 1103 catch { grab release $w } 1104 set dialogWaitStack {} 1105 } 1106 1107 if {$dosync} { 1108 gat_syncInterface 1109 } 1110} 1111 1112############################################################################# 1113# 1114# Return the top-level window that w is contained in. 1115# 1116proc gettoplevel {w} { 1117 while {1} { 1118 set pw [winfo parent $w] 1119 if { $pw == "" || $pw == "."} break 1120 set w $pw 1121 } 1122 return $w 1123} 1124 1125############################################################################# 1126# 1127# If a number is prepended with a '*', scale it by the current font scale. 1128# 1129proc rescale {n} { 1130 if {[string index $n 0] == "*"} { 1131 return [expr int([getFontScale dialogExpFont 13] * [string range $n 1 end])] 1132 } 1133 1134 return $n 1135} 1136 1137############################################################################# 1138# 1139# Return non-zero if $c is a character from a word ( alphanumeric or "_"). 1140# 1141proc iswordchar {c} { 1142 if { [string is alnum $c] || $c == "_" } { 1143 return 1 1144 } 1145 return 0 1146} 1147 1148############################################################################# 1149# 1150# Return non-zero if $c is a character from a word including task names ( alphanumeric, "_" or "$"). 1151# 1152proc istaskwordchar {c} { 1153 if { [string is alnum $c] || $c == "_" || $c == "\$" } { 1154 return 1 1155 } 1156 return 0 1157} 1158 1159############################################################################# 1160# 1161# Find the position of the first occurance of $word in $line with the 1162# restriction that $word must be surrounded by non-word characters or at the 1163# start or end of a line. Returns -1 if $word is not found 1164# 1165proc findword {line word} { 1166 set llen [string length $line] 1167 set wlen [string length $word] 1168 set p 0 1169 while {[set p [string first $word [string range $line $p end]]] >= 0 } { 1170 if { ($p == 0 || ! [iswordchar [string index $line [expr $p - 1 ]]]) \ 1171 && ($p+$wlen >= $llen || ! [iswordchar [string index $line [expr $p + $wlen ]]]) } { 1172 break 1173 } 1174 } 1175 1176 return $p 1177} 1178 1179 1180proc lpop {_l} { 1181 upvar $_l l 1182 1183 set l [lrange $l 0 [expr [llength $l] - 2]] 1184} 1185 1186proc lscan {l args} { 1187 set i 0 1188 1189 foreach v $args { 1190 upvar $v _v$i 1191 1192 set _v$i [lindex $l $i] 1193 incr i 1194 } 1195} 1196 1197proc llast {l} { 1198 set n [llength $l] 1199 if {$n > 0} { 1200 return [lindex $l [expr $n - 1]] 1201 } else { 1202 return "" 1203 } 1204} 1205 1206proc makeFriendlyChar {c} { 1207 if {[string is graph $c] || $c == " " } { return $c } 1208 set n 0 1209 binary scan $c c n 1210 1211 return \\[format %03o $n] 1212} 1213 1214proc findLibraryFile {name} { 1215 global tkg_simVLibPath 1216 1217 foreach directory $tkg_simVLibPath { 1218 set directory [namespace eval :: "eval concat $directory"] 1219 if {[file exists $directory/$name]} { 1220 return $directory/$name 1221 } 1222 if {[file exists $directory/$name.v]} { 1223 return $directory/$name.v 1224 } 1225 } 1226 1227 return "" 1228} 1229 1230proc encodeBits {b value} { 1231 set n [llength $value] 1232 1233 set out 0 1234 for {set i 0} {$i < $n} {incr i} { 1235 if {[lindex $value $i]} { 1236 set out [expr $out | (1 << $i)] 1237 } 1238 } 1239 return $out 1240} 1241 1242proc validate_hex {s} { 1243 if {[scan $s %x n] != 1} { 1244 set n 0 1245 } 1246 return $n 1247} 1248 1249proc validate_posint {s} { 1250 if {[scan $s %d n] != 1 || $n < 1} { 1251 set n 1 1252 } 1253 return $n 1254} 1255 1256proc validate_nonnegint {s} { 1257 if {[scan $s %d n] != 1 || $n < 0} { 1258 set n 0 1259 } 1260 return $n 1261} 1262 1263proc validate_int {s} { 1264 if {[scan $s %d n] != 1} { 1265 set n 0 1266 } 1267 return $n 1268} 1269 1270# 1271# Create a basic toolbar button 1272# 1273proc toolbutton {w img act help args} { 1274 set state normal 1275 1276 parseargs $args {-state} 1277 1278 if {[catch {button $w -image [gifI $img] -takefocus 0 -relief flat -command $act -overrelief raised -state $state}]} { 1279 button $w -image [gifI $img] -takefocus 0 -relief flat -command $act -state $state 1280 } 1281 1282 if { $help != ""} { 1283 helpon $w [m $help] 1284 } 1285} 1286 1287# 1288# Validate function for bit size selector. All chars must be digits, and there 1289# is a 3 char maximum. 1290# 1291proc hexValidate {w act cur c newv} { 1292 if {$act == 1} { 1293 return [string is xdigit $c] 1294 } 1295 1296 return 1 1297} 1298 1299proc _incdecDelta {varName args} { 1300 upvar \#0 $varName v 1301 1302 set min 0 1303 set max 2147483648 1304 set format %f 1305 set delta 1 1306 parseargs $args {-delta -min -max -format} 1307 1308 scan $v $format n 1309 1310 set newValue [expr $n + $delta] 1311 1312 if { $newValue < $min } { set newValue $min } 1313 if { $newValue > $max } { set newValue $max } 1314 set v [format $format $newValue] 1315} 1316 1317proc incdecEntry {w args} { 1318 frame $w 1319 1320 entry $w.e 1321 1322 set class "" 1323 set variable "" 1324 set min 0 1325 set max 1e20 1326 set width 8 1327 set format %f 1328 set justify right 1329 set validatecommand "" 1330 set font [$w.e cget -font] 1331 set delta 1 1332 parseargs $args {-variable -width -min -max -class -delta -format -justify -validatecommand -font} 1333 1334 if { $validatecommand != "" } { 1335 $w.e configure -bg white -width $width -textvariable $variable -justify $justify \ 1336 -validate key -validatecommand "$validatecommand %W %d %s %S %P" \ 1337 -invalidcommand bell -font $font 1338 } else { 1339 $w.e configure -bg white -width $width -textvariable $variable -justify $justify -font $font 1340 } 1341 button $w.up -image [gifI up.gif] -command "_incdecDelta $variable -delta $delta -max $max -min $min -format $format" 1342 button $w.dn -image [gifI down.gif] -command "_incdecDelta $variable -delta [expr -$delta] -max $max -min $min -format $format" 1343 1344 if { $class != "" } { 1345 bindtags $w.e [concat [list $class] [bindtags $w.e]] 1346 } 1347 1348 pack $w.e -side left 1349 pack $w.up -side top -fill y -expand 1 1350 pack $w.dn -side bottom -fill y -expand 1 1351} 1352 1353proc replaceSwitchValue {cmd sname value} { 1354 set i [lsearch $cmd $sname] 1355 if {$i < 0} return $cmd 1356 incr i 1357 return [lreplace $cmd $i $i $value] 1358} 1359 1360proc incdecEntry_configure {w args} { 1361 parseargs $args {-min -max -delta} 1362 1363 set upcommand [$w.up cget -command] 1364 set dncommand [$w.dn cget -command] 1365 1366 if {[info exists min]} { 1367 set upcommand [replaceSwitchValue $upcommand -min $min] 1368 set dncommand [replaceSwitchValue $dncommand -min $min] 1369 } 1370 if {[info exists max]} { 1371 set upcommand [replaceSwitchValue $upcommand -max $max] 1372 set dncommand [replaceSwitchValue $dncommand -max $max] 1373 } 1374 if {[info exists delta]} { 1375 set upcommand [replaceSwitchValue $upcommand -delta $delta] 1376 set dncommand [replaceSwitchValue $dncommand -delta [expr -$delta]] 1377 } 1378 1379 $w.up configure -command $upcommand 1380 $w.dn configure -command $dncommand 1381} 1382 1383proc chooseInterval {D} { 1384 1385 set G [expr exp(int(log($D)/log(10.0)+0.999999999)*log(10.0))] 1386 set Q [expr ($G-$D)/$G ] 1387 1388 if {$Q >= 0.8} { return [expr $G*0.02 ] } 1389 1390 if {$Q >= 0.6} { return [expr $G*0.05 ] } 1391 1392 return [expr $G*0.1 ] 1393} 1394 1395# 1396# add pads on the top and botton of a window packed with "pack" 1397# 1398proc packPad {w args} { 1399 1400 set toppad 10 1401 set bottompad 10 1402 1403 parseargs $args {-pad -toppad -bottompad} 1404 if {[info exists pad]} { 1405 set toppad $pad 1406 set bottompad $pad 1407 } 1408 1409 frame $w.pad_top -height [rescale *$toppad] 1410 frame $w.pad_bottom -height [rescale *$bottompad] 1411 pack $w.pad_top -side top 1412 pack $w.pad_bottom -side bottom 1413} 1414 1415proc linkVars_change {v1 v2 n args} { 1416 global linkVars_assoc 1417 upvar \#0 $v1 _v1 1418 upvar \#0 $v2 _v2 1419 1420 set assoc $linkVars_assoc($v1:$v2) 1421 1422 if {$n == 1} { 1423 set p [assocn $_v1 0 $assoc] 1424 set new_v2 [lindex $p 1] 1425# puts "$v1 changed to $_v1, $v2 will become $new_v2" 1426 if { $new_v2 != $_v2 } { 1427 set _v2 $new_v2 1428 } 1429 } else { 1430 set p [assocn $_v2 1 $assoc] 1431 set new_v1 [lindex $p 0] 1432# puts "$v2 changed to $_v2, $v1 will become $new_v1" 1433 if { $new_v1 != $_v1 } { 1434 set _v1 $new_v1 1435 } 1436 } 1437} 1438 1439############################################################################# 1440# 1441# Link values of v1 and v2 with an association list. When one variable 1442# changes, the other will change to reflect corresponding value in the 1443# association list. 1444# 1445proc linkVars {v1 v2 assoc} { 1446 global linkVars_assoc 1447 upvar \#0 $v1 _v1 1448 upvar \#0 $v2 _v2 1449 1450 set linkVars_assoc($v1:$v2) $assoc 1451 trace variable _v1 w "linkVars_change $v1 $v2 1" 1452 trace variable _v2 w "linkVars_change $v1 $v2 2" 1453} 1454 1455
