1############################################################################# 2# Author: # 3# ------ # 4# Anton Kokalj Email: Tone.Kokalj@ijs.si # 5# Department of Physical and Organic Chemistry Phone: x 386 1 477 3523 # 6# Jozef Stefan Institute Fax: x 386 1 477 3811 # 7# Jamova 39, SI-1000 Ljubljana # 8# SLOVENIA # 9# # 10# Source: $XCRYSDEN_TOPDIR/Tcl/genWidget.tcl 11# ------ # 12# Copyright (c) 1996-2003 by Anton Kokalj # 13############################################################################# 14 15# in this file are GENERAL WIDGET procedures like DIALOGS, ... !!! 16 17proc RadioButtons { parent varname side args } { 18 # side -- value for -side option 19 set f [frame $parent.choices -relief groove -borderwidth 2] 20 set b 0 21 foreach item $args { 22 radiobutton $f.$b -variable $varname \ 23 -text $item -value $item -anchor sw 24 pack $f.$b -side $side -fill both -padx 10 -pady 5 25 incr b 26 } 27 pack $f -side top -ipadx 3 -ipady 3 -padx 5 -pady 5 28} 29 30 31proc RadioBut { parent labeltext varname lside rside ring \ 32 expand args } { 33 # labeltext -- text to display in label 34 # varname -- name of variable 35 # lside -- value for -side option for label 36 # rside -- value for -side option for radiobutton 37 # ring -- wheather $f's relief is groove or not !!! 38 # expand -- value for -expand option 39 40 set wlist {} 41 42 if { $ring == 1 } { 43 set f [frame $parent.f -relief groove -borderwidth 2] 44 } else { 45 set f [frame $parent.f -borderwidth 0] 46 } 47 set f1 [frame $f.lbl -bd 0] 48 set f2 [frame $f.f2 -bd 0] 49 set lbl [label $f1.lbl -text $labeltext -anchor center] 50 pack $f1 $f2 $lbl -side $lside -padx 0 -padx 0 \ 51 -ipadx 0 -ipady 0 -expand $expand -fill both 52 53 set wlist $lbl 54 set b 0 55 foreach item $args { 56 radiobutton $f2.$b -variable $varname \ 57 -text $item -value $item -anchor sw 58 pack $f2.$b -side $rside -fill both -padx 0 -pady 0 \ 59 -ipadx 0 -ipady 0 -expand $expand 60 lappend wlist $f2.$b 61 incr b 62 } 63 pack $f -side $lside -ipadx 0 -ipady 0 -padx 2 -pady 2 \ 64 -fill x -expand $expand 65 return $wlist 66} 67 68 69proc RadioButCmd { parent labeltext varname cmd lside rside ring \ 70 expand padx args } { 71 global radio_but_cmd_frame 72 # labeltext -- text to display in label 73 # varname -- name of variable 74 # cmd -- command to execute--> a value of $item is passed to cmd 75 # ^^^^^ 76 # lside -- value for -side option for label 77 # rside -- value for -side option for radiobutton 78 # ring -- wheather $f's relief is groove or not !!! 79 # padx -- padx value for groove frame 80 # expand -- value for -expand option 81 82 set wlist {} 83 84 if { $ring == 1 } { 85 set f [frame [WidgetName $parent] -relief groove -borderwidth 2] 86 } else { 87 set f [frame [WidgetName $parent] -borderwidth 0] 88 } 89 set radio_but_cmd_frame $f 90 91 set f1 [frame $f.lbl -bd 0] 92 set f2 [frame $f.f2 -bd 0] 93 set lbl [label $f1.lbl -text $labeltext -anchor center] 94 pack $f1 $f2 $lbl $lbl -side $lside -padx 0 -pady 0 \ 95 -ipadx 0 -ipady 0 -expand $expand 96 97 set wlist $lbl 98 99 set b 0 100 foreach item $args { 101 radiobutton $f2.$b -variable $varname \ 102 -text $item -value $item \ 103 -anchor center \ 104 -command [list $cmd $item] 105 pack $f2.$b -side $rside -fill both -padx 0 -pady 0 \ 106 -ipadx 0 -ipady 0 -expand $expand 107 lappend wlist $f2.$b 108 incr b 109 } 110 pack $f -side $lside -ipadx 0 -ipady 0 -padx $padx -pady 2 \ 111 -fill x -expand $expand 112 113 return $wlist 114} 115 116 117proc RadioButVarCmd { parent labeltext varname cmd lside rside ring \ 118 expand args } { 119 # labeltext -- text to display in label 120 # varname -- name of variable 121 # cmd -- command to execute--> a value of $varname is passed to cmd 122 # ^^^^^^^^ 123 # lside -- value for -side option for label 124 # rside -- value for -side option for radiobutton 125 # ring -- wheather $f's relief is groove or not !!! 126 # expand -- value for -expand option 127 128 if { $ring == 1 } { 129 set f [frame $parent.f -relief groove -borderwidth 2] 130 } else { 131 set f [frame $parent.f -borderwidth 0] 132 } 133 set f1 [frame $f.lbl -bd 0] 134 set f2 [frame $f.f2 -bd 0] 135 set lbl [label $f1.lbl -text $labeltext -anchor center] 136 pack $f1 $f2 $lbl $lbl -side $lside -padx 0 -padx 0 \ 137 -ipadx 0 -ipady 0 138 set b 0 139 foreach item $args { 140 radiobutton $f2.$b -variable $varname \ 141 -text $item -value $item \ 142 -command [list $cmd $varname] -anchor sw 143 pack $f2.$b -side $rside -fill both -padx 0 -pady 0 \ 144 -ipadx 0 -ipady 0 145 incr b 146 } 147 pack $f -side $lside -ipadx 0 -ipady 0 -padx 2 -pady 2 \ 148 -fill x -expand $expand 149} 150 151 152proc CheckButVarCmd { parent varname cmd side ring expand args } { 153 # varname -- name of variable 154 # cmd -- command to execute--> a value of $varname is passed to cmd 155 # ^^^^^^^^ 156 # side -- value for -side option for radiobutton 157 # ring -- wheather $f's relief is groove or not !!! 158 # expand -- value for -expand option 159 160 if { $ring == 1 } { 161 set f [frame $parent.f -relief groove -borderwidth 2] 162 } else { 163 set f [frame $parent.f -borderwidth 0] 164 } 165 set b 0 166 foreach item $args { 167 checkbutton $f.$b -variable $varname \ 168 -onvalue On -offvalue Off -text $item \ 169 -command [list $cmd $varname] -anchor sw 170 pack $f.$b -side $side -fill both -padx 0 -pady 0 \ 171 -ipadx 0 -ipady 0 172 incr b 173 } 174 pack $f -side $side -ipadx 0 -ipady 0 -padx 2 -pady 2 \ 175 -fill x -expand $expand 176 return $f 177} 178 179 180proc CheckButtons { parent args } { 181 set f [frame $parent.booleans -borderwidth 5] 182 set b 0 183 foreach item $args { 184 checkbutton $f.$b -text $item -variable $item 185 pack $f.$b -side left 186 incr b 187 } 188 pack $f -side top 189} 190 191 192proc CheckVarButtons { parent 193 labellist 194 varlist 195 side 196 {onvalue 1} 197 {offvalue 0} 198 } { 199 set f [frame $parent.booleans -borderwidth 5] 200 set b 0 201 foreach label $labellist var $varlist { 202 frame $f.$b 203 checkbutton $f.$b.cb -text $label -variable $var \ 204 -onvalue $onvalue -offvalue $offvalue 205 pack $f.$b -side $side -fill x -expand 1 206 pack $f.$b.cb -side left 207 incr b 208 } 209 pack $f -side top 210} 211 212 213proc Entries { w lablist entrylist width {expand {1}} {side {left}} \ 214 {args {}}} { 215 # w - widget 216 # lablist - list of labels 217 # entrylist - list of entries variables 218 # width - width of entry 219 # expand - parameter for -expand option 220 221 frame $w.frame 222 pack $w.frame -expand $expand 223 224 set n 1 225 foreach ebl $entrylist { 226 set m [expr $n - 1] 227 label $w.frame.lab$n -text [lindex $lablist $m] 228 entry $w.frame.entry$n -relief sunken -width $width \ 229 -textvariable $ebl 230 eval {pack $w.frame.lab$n $w.frame.entry$n -side $side \ 231 -padx 5 -pady 5 -anchor w} $args 232 incr n 233 } 234 return $w.frame.entry1 235} 236 237 238proc OneEntries { w lablist entrylist labelwidth ewidth {pady 5} {args {}}} { 239 # w - widget 240 # lablist - list of labels 241 # entrylist - list of entries variables 242 # labelwidth - width of label 243 # ewidth - width of entry 244 245 set n 1 246 foreach ebl $entrylist { 247 frame $w.frame$n 248 if { $args != {} } { 249 eval {pack $w.frame$n} $args 250 } else { 251 pack $w.frame$n 252 } 253 set m [expr $n - 1] 254 label $w.frame${n}.lab$n -text [lindex $lablist $m] \ 255 -width $labelwidth \ 256 -anchor w 257 entry $w.frame${n}.entry$n -relief sunken \ 258 -textvariable $ebl \ 259 -width $ewidth 260 261 lappend foclist $w.frame${n}.entry$n 262 263 pack $w.frame${n}.lab$n -side left -padx 5 -pady $pady 264 pack $w.frame${n}.entry$n -side right -padx 5 -pady $pady \ 265 -fill x -expand 1 266 incr n 267 } 268 269 return $foclist 270} 271 272 273proc dialog {win title text bitmap default args} { 274 global button 275 276 #win - name of top level window 277 #title - title of toplevel window 278 #text/bitmap - text/bitmap to be dispayed in the Dialog 279 #default - index of default button; -1 if none 280 #args - strings to be displayed in the buttons 281 282 # from where do we came here, that we'll be able to set 283 # the grab back where it was before 284 285 set oldgrab [grab current] 286 # 1. create TOP_LEVEL & divdide into TOP & BOTTOM 287 288 toplevel $win -class Dialog 289 wm title $win $title 290 wm iconname $win Dialog 291 frame $win.top -relief raised -bd 1 292 pack $win.top -side top -fill both 293 frame $win.bot -relief raised -bd 1 294 pack $win.bot -side bottom -fill both 295 296 xcPlace . $win 200 200 297 # 2. fill TOP with bitmap & message 298 message $win.top.msg -text $text -aspect 500 299 set font [ModifyFont fixed $win.top.msg \ 300 -family helvetica -weight bold -size 12] 301 $win.top.msg config -font $font 302 pack $win.top.msg -side right -expand 1 -fill both \ 303 -padx 5m -pady 5m 304 if {$bitmap != "" } { 305 label $win.top.bitmap -bitmap $bitmap 306 pack $win.top.bitmap -side left -padx 5m -pady 5m 307 } 308 309 # 3. create a row of buttons at the BOTTOM 310 311 set i 0 312 foreach but $args { 313 if {$i == $default} { 314 frame $win.bot.default -relief sunken -bd 2 315 button $win.bot.default.button$i -text $but \ 316 -command "set button $i" 317 pack $win.bot.default -side left -expand 1 \ 318 -padx 5m -pady 2m 319 pack $win.bot.default.button$i -side left \ 320 -padx 2m -pady 2m -ipadx 2m -ipady 1m 321 focus $win.bot.default.button$i 322 } else { 323 frame $win.bot.rest -bd 10 324 button $win.bot.rest.button$i -text $but \ 325 -command "set button $i" 326 pack $win.bot.rest -side left -expand 1 \ 327 -padx 5m -pady 2m 328 pack $win.bot.rest.button$i -side left -expand 1 \ 329 -padx 2m -pady 2m -ipadx 2m -ipady 1m 330 } 331 incr i 332 } 333 334 # 4. Set up binding for <Return> 335 336 if {$default > 0} { 337 bind $win.bot.default.button$default <Return> \ 338 "$win.bot.default.button$default flash; \ 339 set button $default" 340 } 341 342 343 # set a grab 344 345 tkwait visibility $win 346 catch { grab $win } 347 348 # 5. Wait for the user to respond, then release the grab 349 # and return the index of the selected button. 350 351 tkwait variable button 352 destroy $win 353 catch { grab release $win } 354 355 # set grab to "old one" 356 if { $oldgrab != {} } { 357 catch { grab $oldgrab } 358 } 359 return $button 360} 361 362 363proc xcToplevel {w title iconname {master {.}} {x {0}} {y {0}} {transient 1}} { 364 # w............name of toplevel 365 # title........title of toplevel 366 # iconname 367 # master.......name of widow that will be used to place toplevel 368 # x,y..........where to place toplevel 369 370 #if { [winfo exist $w] } { 371 # xcDebug -stderr "\n\n\n DEBUG> toplevel \"$w\" already exist!!!!\n\ 372 # ERROR: please report to autor: Tone.Kokalj@ijs.si\n" 373 # return 374 #} 375 376 377 if { [winfo exist $w] } { 378 # toplevel already exists; return from the calling proc 379 return -code return 380 } 381 382 toplevel $w 383 if { $master != "" } { 384 xcPlace $master $w $x $y 385 raise $w 386 } 387 wm title $w $title 388 wm iconname $w $iconname 389 390 if { $transient } { 391 wm transient $w [winfo toplevel [winfo parent $w]] 392 } 393 return $w 394} 395 396 397# make text widget with xscrollball & yscrollbar and insert text 398proc DispText {f text w h {update 0}} { 399 # f... window (YET TO BE CREATED) 400 # text... text to be displayed 401 # w... width of text widget 402 # h... height of text widget 403 # update if $f elready exists && update=1 -> just update the text 404 # 405 # PROC RETURNS name of text widget or 0 if it fails!!!!!!! 406 407 # frame $f may already exists 408 if { ![winfo exists $f] } { 409 xcDebug -debug "#1" 410 frame $f 411 pack $f -side top -expand true -fill both 412 set fb [frame $f.bottom ] 413 set font [SetFont text -family courier -size 14] 414 set t [text $f.t -setgrid true -wrap none -width $w -height $h \ 415 -font $font \ 416 -yscrollcommand "$f.sy set" -xscrollcommand "$fb.sx set"] 417 puts stderr "TEXT-WIDGET: $t" 418 419 scrollbar $f.sy -orient vert -command "$f.t yview" 420 scrollbar $fb.sx -orient hori -command "$f.t xview" 421 xcDebug -debug "#2" 422 #set tplw .[lindex [split $f .] 1]; # whatfore is that used ???? 423 # Create padding based on the scrollbar width and border 424 set pad [expr [$f.sy cget -width] + 2 * \ 425 ([$f.sy cget -bd] + \ 426 [$f.sy cget -highlightthickness])] 427 frame $fb.pad -width $pad -height $pad 428 xcDebug -debug "#3" 429 pack $fb -side bottom -fill x 430 pack $fb.pad -side right 431 pack $fb.sx -side bottom -fill x 432 pack $f.sy -side right -fill y 433 pack $f.t -side left -fill both -expand true 434 xcDebug -debug "#4" 435 $f.t insert end $text 436 $f.t config -state disabled 437 return $f.t 438 } elseif $update { 439 # just update text 440 set dis 0 441 if { [$f.t cget -state] == "disabled" } { 442 set dis 1 443 $f.t configure -state normal 444 } 445 $f.t delete 1.0 end 446 $f.t insert 1.0 $text 447 448 if $dis { 449 $f.t configure -state disabled 450 } 451 return $f.t 452 } 453 return 0 454} 455 456 457proc OneEntryToplevel {w title iconname text width varname vartype x y} { 458 global done oneentry 459 upvar $varname var 460 461 if ![info exist var] { set var {} } 462 set oneentry $var 463 update 464 xcDebug "OneEntryToplevel:: $oneentry" 465 xcToplevel $w $title $iconname . $x $y 466 set f1 [frame $w.f1 -relief raised -bd 2] 467 set f2 [frame $w.f2 -relief raised -bd 2] 468 set l1 [label $f1.l1 -text $text] 469 set e1 [entry $f1.e1 -relief sunken -width $width -textvariable oneentry] 470 focus $e1 471 set varlist [list "oneentry $vartype"] 472 set foclist $e1 473 puts stdout "varlist:: $varlist" 474 puts stdout "foclist:: $foclist" 475 set b1 [button $f2.ok -text "OK" \ 476 -command [list OneEntryOK $varlist $foclist]] 477 set b2 [button $f2.can -text "Cancel" \ 478 -command [list CancelProc $w]] 479 pack $f1 $f2 -side top -fill both -padx 0 -pady 0 480 pack $l1 $e1 -side top -expand 1 -padx 10 -pady 5 481 pack $b1 $b2 -side left -expand 1 -padx 5 -pady 5 482 483 bind $e1 <Return> [list OneEntryOK $varlist $foclist] 484 bind $b1 <Return> [list OneEntryOK $varlist $foclist] 485 tkwait visibility $w 486 # check if there is some window grabed 487 set oldgrab [grab current] 488 catch { grab $w } 489 490 tkwait variable done 491 destroy $w 492 if { $oldgrab != ""} { 493 catch { grab $oldgrab } 494 } 495 set var $oneentry 496 xcDebug "OneEntryToplevel:: $oneentry" 497 return $varname 498} 499 500 501proc OneEntryOK {varlist foclist} { 502 global err done 503 504 check_var $varlist $foclist 505 if $err {return} 506 set done 1 507} 508 509 510# proc makes Scrolled Entries on a Canvas 511proc ScrollEntries { parent nn label labellist arraylist arraytypelist \ 512 width globvar buttonlist cheight } { 513 global varlist foclist 514 515 puts stdout "GLOBVAR NAME:: $globvar" 516 517 # nn .... number of Entries 518 # label ........ top label 519 # labellist .... list of labels 520 # arraylist .... list of array elements 521 # expamle: set arraylist "LB, NA," 522 # name of variables is completed as: 523 # $globvar(${varitem},$i) 524 # arraytypelist . type of variable in array 525 # width .... width of entries 526 # globvar name of global variable 527 # buttonlist .... 0 -> button do not exists 528 # 1 -> "<text1> <command1> <args1>" -> 1 button exist 529 # 2 -> "<text1> <command1> <args1>" "<text2> <command2> <args2>" -> 2 buttons exists 530 # n -> "list #1" "list #2" ... "list #n" 531 # cheight .... height of canvas (Entries are units of height) 532 533 534 # frame where canvas&scrollbar will be!! 535 set ft [frame $parent.ft -relief sunken -bd 2] 536 pack $ft -side top -expand true -fill y 537 538 set c [canvas $ft.canv -yscrollcommand [list $ft.yscroll set]] 539 set scb [scrollbar $ft.yscroll -orient vertical -command [list $c yview]] 540 pack $scb -side right -fill y 541 pack $c -side left -fill both -expand true 542 543 # create FRAME to hold every LABEL&ENTRY 544 set f [frame $c.f -bd 0] 545 $c create window 0 0 -anchor nw -window $f -tags frame 546 set varlist "" 547 set foclist "" 548 for {set i 1} {$i <= $nn} {incr i 1} { 549 frame $f.fr$i -relief groove -bd 2 550 pack $f.fr$i -padx 5 -pady 5 -expand 1 551 label $f.fr${i}.label$i -text "$label $i" 552 pack $f.fr${i}.label$i -anchor w -padx 7 -pady 7 553 frame $f.fr${i}.frm$i 554 pack $f.fr${i}.frm$i -side top -anchor center 555 # coplite the varlist 556 set tmplist "" 557 set n 0 558 foreach item $arraylist { 559 set var ${globvar}(${item},${i}) 560 append tmplist " $var " 561 puts stdout "TMPLIST:: $var" 562 # make a varlist for PROC CHECK_VAR 563 lappend varlist "$var [lindex $arraytypelist $n]" 564 incr n 565 } 566 Entries $f.fr${i}.frm$i $labellist $tmplist $width 567 set nb [lindex $buttonlist 0] 568 for {set j 1} {$j <= $nb} {incr j} { 569 set com [lindex $buttonlist $j] 570 puts stdout "COM::: [list $com $i]" 571 set b [button $f.fr${i}.frm$i.b$j -text [lindex $com 0] \ 572 -command [concat [lrange $com 1 end] $i]] 573 pack $b -side right -before $f.fr${i}.frm$i.frame -padx 10 -pady 5 574 } 575 # make a foclist for PROC CHECK_VAR 576 lappend foclist \ 577 $f.fr${i}.frm$i.frame.entry1 $f.fr${i}.frm$i.frame.entry2 578 } 579 580 puts stdout "FOCLIST: $foclist\n\n" 581 puts stdout "VARLIST: $varlist" 582 set child [lindex [pack slaves $f] 0] 583 584 # set the focus to first entry that upper FOR-LOOP create 585 focus $f.fr1.frm1.frame.entry1 586 587 tkwait visibility $child 588 set width [winfo width $f] 589 set height [winfo height $f] 590 if { $nn < $cheight } { 591 $c config -width $width -height $height 592 } else { 593 $c config -width $width -height [expr $height / $nn * $cheight] \ 594 -scrollregion "0 0 $width $height" 595 } 596 597 return [list $varlist $foclist] 598} 599 600 601#----------------------------- 602# SCROLLEDLISTBOX2 603#----------------------------- 604proc ScrolledListbox2 { parent args } { 605 frame $parent 606 pack $parent -side left -fill both -expand true -padx 5 -pady 10 607 # Create listbox attached to scrollbars, pass thru $args 608 eval {listbox $parent.list \ 609 -yscrollcommand [list $parent.sy set] \ 610 -xscrollcommand [list $parent.sx set]} $args 611 scrollbar $parent.sy -orient vertical \ 612 -command [list $parent.list yview] 613 # Create extra frame to hold pad and horizontal scrollbar 614 frame $parent.bottom 615 scrollbar $parent.sx -orient horizontal \ 616 -command [list $parent.list xview] 617 # Create padding based on the scrollbar width and border 618 set pad [expr [$parent.sy cget -width] + 2* \ 619 ([$parent.sy cget -bd] + \ 620 [$parent.sy cget -highlightthickness])] 621 frame $parent.pad -width $pad -height $pad 622 # Arrange everything in the parent frame 623 pack $parent.bottom -side bottom -fill x 624 pack $parent.pad -in $parent.bottom -side right 625 pack $parent.sx -in $parent.bottom -side bottom -fill x 626 pack $parent.sy -side right -fill y 627 pack $parent.list -side left -fill both -expand true 628 return $parent.list 629} 630#------------------------------------ 631# END OF SCROLLEDLISTBOX2 632#------------------------------------ 633 634 635 636proc xcMenuEntry {parent l_text e_width e_var m_list {args {}}} { 637 global system 638 # parent ... parent widget 639 # l_text ... text for label 640 # e_width ... width of entry 641 # e_var ... entry's textvariable 642 # m_list ... list of menu's entries 643 # args ... additional argumets that must be processed; 644 # -entryXXXXX means XXXXX atribute for entry 645 646 set l [label $parent.l -text $l_text] 647 set e [entry $parent.e -textvariable $e_var -width $e_width] 648 set mb [menubutton $parent.mb \ 649 -bitmap "@$system(BMPDIR)/xcMenuEntry_down.xbm" \ 650 -menu $parent.mb.menu -relief raised] 651 652 set menu [menu $mb.menu -tearoff 0 -relief raised] 653 foreach word $m_list { 654 $menu add command -label $word -command [list set $e_var "$word"] 655 } 656 657 # take care of options in $args 658 if {$args == {}} { return 1 } 659 set i 0 660 foreach option $args { 661 incr i 662 if { $i%2 } { 663 set tag $option 664 } else { 665 switch -- $tag { 666 "-labelrelief" {$l configure -relief $option} 667 "-labelwidth" {$l configure -width $option} 668 "-labelanchor" {$l configure -anchor $option} 669 "-labelfont" {$l configure -font $option} 670 "-entryrelief" {$e configure -relief $option} 671 "-entryfont" {$e configure -font $option} 672 "-entrystate" {$e configure -state $option} 673 "-menubuttonrelief" {$mb configure -relief $option} 674 "-menurelief" {$menu configure -relief $option} 675 default { tk_dialog .mb_error Error \ 676 "ERROR: Bad xcMenuEntry configure option $tag" \ 677 error 0 OK } 678 } 679 } 680 } 681 682 if { $i%2 } { 683 tk_dialog .mb_error1 Error "ERROR: You called xcMenuEntry with an odd number of args !" \ 684 error 0 OK 685 return 0 686 } 687 688 pack $l -side left -padx 5 -pady 5 689 pack $e -side left -fill x -pady 5 690 pack $mb -side left -ipadx 2 -ipady 2 -pady 5 -padx 5 691 692 return $e 693} 694 695 696proc FillEntries { w lablist entrylist l_width e_width \ 697 {f_side top} {side left} {args {}}} { 698 global xcFonts fillEntries 699 # w - parent widget 700 # lablist - list of labels 701 # entrylist - list of entries variables 702 # l_width - width of label 703 # e_width - width of entry 704 # f_side - how to pack frame that holds frame & entry 705 # side - how to pack label & entry 706 # args - configuring options 707 set e_rel sunken 708 set e_sta normal 709 set e_bg [GetWidgetConfig entry -background] 710 set e_font $xcFonts(normal_entry) 711 set l_font $xcFonts(normal) 712 set i 0 713 xcDebug "FillEntries Args:: $args" 714 foreach option $args { 715 incr i 716 # odd cycles are tags, even options 717 if { $i%2 } { 718 set tag $option 719 } else { 720 xcDebug "FillEntries Options:: $tag $option" 721 switch -- $tag { 722 "-e_relief" {set e_rel $option} 723 "-e_state" {set e_sta $option} 724 "-e_bg" {set e_bg $option} 725 "-e_font" {set e_font $option} 726 "-l_font" {set l_font $option} 727 default { 728 tk_dialog .mb_error Error \ 729 "ERROR: Bad FillEntries configure option $tag" \ 730 error 0 OK 731 return 0 732 } 733 734 } 735 } 736 } 737 if { $i%2 } { 738 tk_dialog .mb_error1 Error \ 739 "ERROR: You called FillEntries with an odd number of args !" \ 740 error 0 OK 741 return 0 742 } 743 744 set i 1 745 for {} {1} {incr i} { 746 if ![winfo exists $w.f$i] { 747 set f $w.f$i 748 break 749 } 750 } 751 752 frame $f 753 pack $f -expand 1 -fill both -side $f_side 754 755 ############################## 756 set n 1 757 if { $e_width == {} } { 758 set e_option [list -relief $e_rel \ 759 -state $e_sta \ 760 -bg $e_bg \ 761 -font $e_font] 762 } else { 763 set e_option [list -relief $e_rel \ 764 -width $e_width \ 765 -state $e_sta \ 766 -bg $e_bg \ 767 -font $e_font] 768 } 769 set fillEntries "" 770 foreach ebl $entrylist { 771 set m [expr $n - 1] 772 set fn [frame $f.$n] 773 label $fn.lab$n -text [lindex $lablist $m] \ 774 -width $l_width -anchor w -font $l_font 775 lappend fillEntries $fn.entry$n 776 eval {entry $fn.entry$n -textvariable $ebl} $e_option 777 pack $fn -side $f_side -expand 1 -fill both -padx 5 -pady 2 778 eval {pack $fn.lab$n -side $side} 779 eval {pack $fn.entry$n -side $side -fill x -expand 1} 780 incr n 781 } 782 return $f.1.entry1 783} 784 785 786 787proc DisplayUpdateWidget {title text} { 788 set t [xcToplevel [WidgetName] $title $title . 200 100 1] 789 set m [message $t.m \ 790 -text $text \ 791 -aspect 500 \ 792 -justify center\ 793 -relief raised -bd 2 \ 794 -background "#f88" ] 795 pack $m -expand 1 -ipadx 20 -ipady 20 -padx 0 -pady 0 796 update 797 #update idletask 798 return $t 799} 800 801 802proc DefaultButton {name {args {}}} { 803 804 set frame [frame $name -relief sunken -bd 2] 805 806 xcDebug "DefaultButton Args:: $args" 807 # args - configuring options 808 set i 0 809 set text "" 810 set command "" 811 foreach option $args { 812 incr i 813 # odd cycles are tags, even options 814 if { $i%2 } { 815 set tag $option 816 } else { 817 xcDebug "DefaultButton Options:: $tag $option" 818 switch -- $tag { 819 "-text" {set text $option} 820 "-command" {set command $option} 821 "-done_var" {set done_var $option} 822 default { 823 tk_dialog [WidgetName] Error \ 824 "ERROR: Bad DefaultButton configure option $tag" \ 825 error 0 OK 826 return 0 827 } 828 } 829 } 830 } 831 if { $i%2 } { 832 tk_dialog .mb_error1 Error \ 833 "ERROR: You called DefaultButton with an odd number of args !" \ 834 error 0 OK 835 return 0 836 } 837 838 if { $command != "" } { 839 button $name.b -text $text -command [list eval $command] 840 } else { 841 button $name.b -text $text -command [list set $done_var 1] 842 } 843 pack $name.b -side left -padx 1m -pady 1m 844 focus $name.b 845 846 return $frame 847} 848 849 850############################################################################### 851# imitate pretty well the tk checkbutton, i.e takes the same option + 852# option -image is possible, but does or have -indicatoron option 853# 854proc xcCheckButton {w args} { 855 global checkButton 856 857 858 # 859 # get "-command" option out of $args 860 # 861 set id [button $w] 862 863 set checkButton($id,pressed) 0 864 set checkButton($id,is_variable) 0 865 866 if {$args == {}} { 867 set args "-command xcCheckButtonDummy" 868 } 869 870 # 871 # set default on/off value 872 # 873 set checkButton($id,offvalue) 0 874 set checkButton($id,onvalue) 1 875 876 set com 0 877 set i 0 878 set arg $args 879 foreach option $arg { 880 incr i 881 if { $i%2 } { 882 set tag $option 883 } else { 884 set j [lsearch $args $tag] 885 switch -- $tag { 886 "-command" { 887 set com 1 888 set args [lreplace $args $j [expr $j + 1]] 889 set command $option 890 } 891 "-offvalue" { 892 set args [lreplace $args $j [expr $j + 1]] 893 set checkButton($id,offvalue) $option 894 } 895 "-onvalue" { 896 set args [lreplace $args $j [expr $j + 1]] 897 set checkButton($id,onvalue) $option 898 } 899 "-selectcolor" { 900 set args [lreplace $args $j [expr $j + 1]] 901 set checkButton($id,selectcolor) $option 902 } 903 "-variable" { 904 set args [lreplace $args $j [expr $j + 1]] 905 set checkButton($id,is_variable) 1 906 set checkButton($id,variable) $option 907 xcDebug "var:: $checkButton($id,variable)" 908 909 } 910 } 911 } 912 } 913 if !$com { 914 set command xcCheckButtonDummy 915 } 916 917 puts stdout "args:: $args\n" 918 flush stdout 919 920 # 921 # now configure the xcCheckButton 922 # 923 eval {$id configure} $args 924 # this should be also tried with binding 925 $id configure -command [concat xcCheckButtonCom $id $command] 926 927 set checkButton($id,normalcolor) [$id cget -bg] 928 if ![info exists checkButton($id,selectcolor)] { 929 set checkButton($id,selectcolor) $checkButton($id,normalcolor) 930 } 931 932 # 933 # set the correct state 934 # 935 if $checkButton($id,is_variable) { 936 upvar #0 $checkButton($id,variable) varn 937 if { $varn == $checkButton($id,onvalue) } { 938 set checkButton($id,pressed) 1 939 $id configure -relief sunken \ 940 -bg $checkButton($w,selectcolor) 941 } 942 } 943 944 return $id 945} 946 947 948proc xcCheckButtonCom {w args} { 949 global checkButton 950 951 if $checkButton($w,is_variable) { 952 upvar #0 $checkButton($w,variable) varn 953 } 954 955 puts stdout "Com:: $w $varn $args" 956 957 if !$checkButton($w,pressed) { 958 # button was pressed 959 set checkButton($w,pressed) 1 960 if $checkButton($w,is_variable) { 961 set varn $checkButton($w,onvalue) 962 } 963 $w configure \ 964 -relief sunken \ 965 -bg $checkButton($w,selectcolor) 966 } else { 967 # button was releassed 968 set checkButton($w,pressed) 0 969 if $checkButton($w,is_variable) { 970 set varn $checkButton($w,offvalue) 971 } 972 $w configure \ 973 -relief raised \ 974 -bg $checkButton($w,normalcolor) 975 } 976 977 eval $args 978} 979 980 981proc xcCheckButtonDummy {} { 982 return 0 983} 984 985 986proc xcCheckButtonRow {parent n bitmaplist varlist comlist \ 987 {fside left} {cbside left}} { 988 # 989 # n ... number of xcCheckButtons 990 # fside ... side of frame to pack 991 # cbside ... side of checkbuttons to pack 992 set f [frame $parent.f] 993 pack $f -side $fside -expand 1 994 995 for {set i 0} {$i < $n} {incr i } { 996 set bmp [lindex $bitmaplist $i] 997 set var [lindex $varlist $i] 998 set com [lindex $comlist $i] 999 puts stdout "$i: $bmp, $var, $com" 1000 set cb($i) [xcCheckButton $f.cb$i \ 1001 -bitmap $bmp \ 1002 -highlightthickness 0 \ 1003 -selectcolor "#ffffff" \ 1004 -command $com \ 1005 -variable $var] 1006 pack $cb($i) -side $cbside 1007 } 1008} 1009 1010 1011# ------------------------------------------------------------------------ 1012# xcModifyColor and related routines 1013# ------------------------------------------------------------------------ 1014 1015proc xcModifyColorID {} { 1016 global mody_col 1017 1018 if ![info exists mody_col(ID)] { 1019 set mody_col(ID) 1 1020 } else { 1021 incr mody_col(ID) 1022 } 1023 return $mody_col(ID) 1024} 1025 1026proc xcModifyColorGetID {} { 1027 global mody_col 1028 1029 if ![info exists mody_col(ID)] { 1030 return 0 1031 } else { 1032 return $mody_col(ID) 1033 } 1034} 1035 1036proc xcModifyColor {parent labeltext init_color \ 1037 frame_relief frame_side scale_side width height \ 1038 scale_length scale_width slider_length {cID {}}} { 1039 global mody_col 1040 1041 if { $cID == {} } { 1042 set cID [xcModifyColorID] 1043 } 1044 1045 set f [frame [WidgetName $parent] -relief $frame_relief -bd 2] 1046 set l [label $f.l -text $labeltext -anchor w] 1047 pack $f -side $frame_side -padx 3 -pady 3 -ipadx 0 -ipady 0 \ 1048 -fill both -expand 1 1049 1050 if ![info exists mody_col($cID,red)] { 1051 set color [rgb_h2f $init_color] 1052 xcDebug "color:: $color" 1053 set mody_col($cID,red) [lindex $color 0] 1054 set mody_col($cID,green) [lindex $color 1] 1055 set mody_col($cID,blue) [lindex $color 2] 1056 } 1057 1058 set fr [frame $f.1 -relief sunken -bd 2] 1059 set mody_col($cID,col) [frame $fr.col -bd 0 -width $width -height $height] 1060 _xcModifyColorSet $cID 1061 1062 set f2 [frame $f.f2 -relief flat] 1063 scale $f2.red -from 0 -to 1 \ 1064 -length $scale_length \ 1065 -variable mody_col($cID,red) \ 1066 -orient horizontal -label "Red:" \ 1067 -digits 4 -resolution 0.001 -showvalue true \ 1068 -width $scale_width \ 1069 -sliderlength $slider_length \ 1070 -highlightthickness 0 \ 1071 -command [list _xcModifyColorSet $cID] 1072 scale $f2.green -from 0 -to 1 \ 1073 -length $scale_length \ 1074 -variable mody_col($cID,green) \ 1075 -orient horizontal -label "Green:" \ 1076 -digits 4 -resolution 0.001 -showvalue true \ 1077 -width $scale_width \ 1078 -sliderlength $slider_length \ 1079 -highlightthickness 0 \ 1080 -command [list _xcModifyColorSet $cID] 1081 scale $f2.blue -from 0 -to 1 \ 1082 -length $scale_length \ 1083 -variable mody_col($cID,blue) \ 1084 -orient horizontal -label "Blue:" \ 1085 -digits 4 -resolution 0.001 -showvalue true \ 1086 -width $scale_width \ 1087 -sliderlength $slider_length \ 1088 -highlightthickness 0 \ 1089 -command [list _xcModifyColorSet $cID] 1090 1091 pack $l -side top -fill x -expand 1 -padx 10 1092 pack $fr $f2 -side $scale_side \ 1093 -fill both -expand 1 -padx 10 -pady 10 -ipadx 0 -ipady 0 1094 pack $mody_col($cID,col) -side top -fill both -expand 1 -padx 0 -pady 0 1095 pack $f2.red $f2.green $f2.blue -side top -fill both -expand 1 \ 1096 -ipadx 0 -ipady 1 -pady 0 1097 1098 return $f 1099} 1100 1101proc _xcModifyColorSet {cID {dummy {}}} { 1102 global mody_col 1103 1104 set mody_col($cID,hxred) [d2h [expr round($mody_col($cID,red) * 255)]] 1105 set mody_col($cID,hxgreen) [d2h [expr round($mody_col($cID,green) * 255)]] 1106 set mody_col($cID,hxblue) [d2h [expr round($mody_col($cID,blue) * 255)]] 1107 $mody_col($cID,col) configure \ 1108 -bg "#$mody_col($cID,hxred)$mody_col($cID,hxgreen)$mody_col($cID,hxblue)" 1109} 1110 1111proc xcModifyColorSet {cID format type color} { 1112 global mody_col 1113 1114 # NOTE: type is RGB or RGBA and is dummy for D and F (for 1115 # compatibility with xcModifyColorGet) 1116 1117 switch -glob -- $format { 1118 D - d* { 1119 # D or decimal 1120 set fc [rgb_d2f $color] 1121 set mody_col($cID,red) [lindex $fc 0] 1122 set mody_col($cID,green) [lindex $fc 1] 1123 set mody_col($cID,blue) [lindex $fc 2] 1124 _xcModifyColorSet $cID 1125 } 1126 F - f* { 1127 # F or float 1128 set mody_col($cID,red) [lindex $color 0] 1129 set mody_col($cID,green) [lindex $color 1] 1130 set mody_col($cID,blue) [lindex $color 2] 1131 _xcModifyColorSet $cID 1132 } 1133 H - h* { 1134 # H or hexadecimal 1135 if { [string toupper $type] == "RGBA" } { 1136 set len [expr {3 * ([string length $color] / 4)}] 1137 set color [string range $color $len] 1138 } 1139 set fc [rgb_h2f $color] 1140 set mody_col($cID,red) [lindex $fc 0] 1141 set mody_col($cID,green) [lindex $fc 1] 1142 set mody_col($cID,blue) [lindex $fc 2] 1143 _xcModifyColorSet $cID 1144 } 1145 deafult { 1146 ErrorDialog "wrong format $format, must be one of D, F, or H" 1147 return 1148 } 1149 } 1150} 1151 1152proc xcModifyColorGet {cID format type} { 1153 global mody_col 1154 1155 switch -glob -- $format { 1156 D - d* { 1157 # D or decimal 1158 set color [rgb_f2d [list $mody_col($cID,red) $mody_col($cID,green) $mody_col($cID,blue)]] 1159 if { [string toupper $type] == "RGBA" } { 1160 append color " 255" 1161 } 1162 } 1163 F - f* { 1164 # F or float 1165 set color [list $mody_col($cID,red) $mody_col($cID,green) $mody_col($cID,blue)] 1166 if { [string toupper $type] == "RGBA" } { 1167 append color " 1.0" 1168 } 1169 } 1170 H - h* { 1171 set color [list $mody_col($cID,hxred) $mody_col($cID,hxgreen) $mody_col($cID,hxblue)] 1172 if { [string toupper $type] == "RGBA" } { 1173 append color "ff" 1174 } 1175 } 1176 default { 1177 ErrorDialog "wrong format $format, must be one of D, F, or H" 1178 return "" 1179 } 1180 } 1181 return $color 1182} 1183# ------------------------------------------------------------------------ 1184# END:: xcModifyColor 1185# ------------------------------------------------------------------------ 1186 1187 1188 1189# xcUpdate is toplevel window with Cancel, Update & Close button 1190proc xcUpdateWindow {{args {}}} { 1191 # options: 1192 # -name 1193 # -title 1194 # -cancelcom 1195 # -closecom 1196 # -updatecom 1197 # -frameside 1198 # -buttonside 1199 # -canceltext 1200 # -closetext 1201 # -updatetext 1202 1203 # defaults 1204 set title "Color Scheme" 1205 set updatecom xcDummyProc 1206 set closecom xcDummyProc 1207 set cancelcom xcDummyProc 1208 set frameside top 1209 set buttonside left 1210 set updatetext Update 1211 set closetext Close 1212 set canceltext Cancel 1213 set name [WidgetName] 1214 # parse args: 1215 set i 0 1216 foreach option $args { 1217 incr i 1218 if { $i%2 } { 1219 set tag $option 1220 } else { 1221 switch -- $tag { 1222 "-name" {set name $option} 1223 "-title" {set title $option} 1224 "-updatecom" {set updatecom $option} 1225 "-closecom" {set closecom $option} 1226 "-cancelcom" {set cancelcom $option} 1227 "-frameside" {set frameside $option} 1228 "-buttonside" {set buttonside $option} 1229 "-updatetext" {set updatetext $option} 1230 "-closetext" {set closetext $option} 1231 "-canceltext" {set canceltext $option} 1232 default { tk_dialog .mb_error Error \ 1233 "ERROR: Bad xcUpdateWindow configure option $tag" \ 1234 error 0 OK } 1235 } 1236 } 1237 } 1238 if { $i%2 } { 1239 tk_dialog .mb_error1 Error "ERROR: You called xcUpdateWindow with an odd number of args !" \ 1240 error 0 OK 1241 return 0 1242 } 1243 1244 set t [xcToplevel $name $title [lrange $title 0 2] . 0 0 1] 1245 1246 set f1 [frame $t.f1 -class RaisedFrame] 1247 set f2 [frame $t.f2 -class RaisedFrame] 1248 pack $f1 $f2 -side $frameside -fill both -expand 1 1249 1250 set can [button $f2.can -text $canceltext -command [list eval $cancelcom]] 1251 set upd [button $f2.upd -text $updatetext -command [list eval $updatecom]] 1252 set clo [button $f2.clo -text $closetext -command [list eval $closecom]] 1253 1254 pack $can $upd $clo -side $buttonside \ 1255 -padx 10 -pady 10 -expand 1 1256 1257 return $f1 1258} 1259 1260proc xcMenuButton {w {args {}}} { 1261 # options: 1262 # -labeltext 1263 # -labelwidth 1264 # -textvariable 1265 # -menu {menutext1 menucom1 ...} 1266 1267 # defaults: 1268 set labeltext {} 1269 set labelwidth {} 1270 set textv xcMisc(dummy) 1271 set menu {{} xcDummyProc} 1272 set side left 1273 1274 # parse args: 1275 set i 0 1276 set wid 0 1277 foreach option $args { 1278 incr i 1279 if { $i%2 } { 1280 set tag $option 1281 } else { 1282 switch -- $tag { 1283 "-labeltext" {set labeltext $option} 1284 "-labelwidth" {set labelwidth $option} 1285 "-textvariable" {set textv $option} 1286 "-side" {set side $option} 1287 "-menu" { 1288 set nm 0 1289 set wid 0 1290 foreach {t c} $option { 1291 set wi [string length $t] 1292 if { $wid < $wi } { set wid $wi } 1293 set text($nm) $t 1294 set com($nm) $c 1295 incr nm 1296 } 1297 incr wid 2 1298 } 1299 default { tk_dialog .mb_error Error \ 1300 "ERROR: Bad xcMenuButton configure option $tag" \ 1301 error 0 OK } 1302 } 1303 } 1304 } 1305 if { $i%2 } { 1306 tk_dialog .mb_error1 Error "ERROR: You called xcMenuButton with an odd number of args !" \ 1307 error 0 OK 1308 return 0 1309 } 1310 1311 set f [frame [WidgetName $w]] 1312 label $f.l -text $labeltext -relief flat -bd 0 -anchor w 1313 if { $labelwidth != {} } { 1314 $f.l config -width $labelwidth 1315 } 1316 upvar $textv value 1317 if { [info exists value] } { 1318 set len [string length $value] 1319 if { $len > $wid } { 1320 set wid $len 1321 } 1322 } 1323 menubutton $f.mb \ 1324 -width $wid \ 1325 -textvariable $textv \ 1326 -menu $f.mb.menu \ 1327 -indicatoron 1 \ 1328 -relief raised 1329 1330 set m [menu $f.mb.menu -tearoff 0] 1331 for {set i 0} {$i < $nm} {incr i} { 1332 $m add command -label $text($i) -command [list eval $com($i)] 1333 } 1334 pack $f.l $f.mb -side $side -padx 1 -fill x -anchor w 1335 return $f 1336} 1337 1338 1339# 1340# xcTextImageButton -- 1341# Create button with text+image but does not pack it 1342# 1343# Arguments: 1344# w name of TextImageButton (it must be packed by the user) 1345# text text of textimagebutton 1346# image image of textimagebutton 1347# side how text and image is packed 1348# args arguments to button command 1349# 1350# Results: 1351# Returns the name of the textimagebutton 1352proc xcTextImageButton {w image side args} { 1353 button $w -highlightthickness 0 1354 $w config -state disabled 1355 set b [eval {button $w.b} $args {-bd 0 -highlightthickness 0}] 1356 set l [label $w.l -image $image -bg "#00f" \ 1357 -anchor c -bd 1 -highlightthickness 0] 1358 1359 #foreach a [list $lt $li] b [list $li $lt] { 1360 # bind $a <Enter> +[list $b config -state active] 1361 # bind $a <Leave> +[list $b config -state normal] 1362 #} 1363 pack $b $l -side $side -fill both 1364 return $w 1365} 1366 1367 1368# 1369# special xcTextImageButton for "Hide" 1370proc xcHideButton {w image side args} { 1371 global xcFonts 1372 1373 set font [SetFont button -size $xcFonts(small_size) -weight bold] 1374 eval {xcTextImageButton $w $image $side} $args {-bg "#00f" -fg "#fff" \ 1375 -activebackground "#88f" -activeforeground "#fff" -font $font} 1376} 1377 1378 1379# 1380# display content of a file in a separate toplevel window 1381# with scroll-text and Close widgets 1382# 1383proc xcDisplayFileText {file {title {Displayed Text}} \ 1384 {w .} {x 0} {y 0} {transient 0}} { 1385 global system prop dispC95out unmapWin 1386 1387 set f_content [ReadFile $file] 1388 1389 return [xcDisplayVarText $f_content $title $w $x $y $transient] 1390} 1391 1392proc xcDisplayVarText {varText {title {Displayed Text}} \ 1393 {w .} {x 0} {y 0} {transient 0}} { 1394 1395 set t [xcToplevel [WidgetName] $title $title $w $x $y $transient] 1396 DispText $t.f1 $varText 80 20 1397 set f2 [frame $t.f2 -relief flat] 1398 pack $t.f1 -side top -expand 1 -fill both -padx 3 -pady 3 1399 pack $f2 -side top -fill x -padx 3 -pady 3 1400 1401 1402 button $f2.close -text "Close" -command [list destroy $t] 1403 pack $f2.close -side top -expand 1 -padx 3 -pady 3 1404 return $t 1405} 1406 1407 1408 1409proc XCRYSDEN_Logo {file} { 1410 global xcMisc system 1411 1412 # 1413 eval destroy [winfo children .] 1414 bind . <Destroy> {} 1415 bind . <Configure> {} 1416 #/ 1417 1418 wm resizable . 0 0 1419 label .xcrysden_logo -image kpath -relief sunken -bd 2 1420 pack .xcrysden_logo -padx 2m -pady 2m -fill both -expand 1 1421 wm geometry . +30+30 1422 wm deiconify . 1423 wm iconbitmap . @$system(BMPDIR)/xcrysden.xbm 1424 wm title . "*** XCrySDen *** " 1425 1426 update 1427} 1428