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/auxil.tcl 11# ------ # 12# Copyright (c) 1996-2003 by Anton Kokalj # 13############################################################################# 14 15proc xcPlace {w1 w2 x y} { 16 # this proc place window w2 near w1 17 # x,y where to place according to w1 18 19 # query geom of w1 20 set geom [wm geometry $w1] 21 set x [expr [lindex [split $geom x+-] 2] + $x] 22 set y [expr [lindex [split $geom x+-] 3] + $y] 23 # now place $w2 to +x +y 24 wm geometry $w2 +$x+$y 25 26 return 27} 28 29 30 31proc Nat2Aname {nat} { 32 global Alist 33 34 # maybe NAT is greater than 100, so 35 set nat [expr $nat % 100] 36 set selA [lindex $Alist $nat] 37 return $selA 38} 39 40 41proc Aname2Nat {atom} { 42 global Alist 43 44 set n 0 45 set Atom [string toupper $atom] 46 foreach elem $Alist { 47 set Elem [string toupper $elem] 48 if { $Atom == $Elem } { return $n } 49 incr n 50 } 51 # if we come so far we have an illegal atom name 52 return "unknown atom name \"$atom\"" 53} 54 55 56proc AnameExt2Nat {atom} { 57 # proc names stands for: AtomNameExtended to Nat 58 # 59 # extended atom name is AtomicSymbolCharacters 60 global Alist 61 62 set n 1 63 set Nat -1 64 foreach elem $Alist { 65 if { [string match -nocase $elem* $atom] } { 66 # first compare if it is two-character match 67 # example: S vs. Se 68 if { [string equal -nocase -length 2 $elem $atom] } { 69 return $n 70 } 71 set Nat $n 72 } 73 incr n 74 } 75 if { $Nat > 0 } { 76 return $Nat 77 } else { 78 # if we come so far we have an illegal atom name 79 return 0 80 } 81} 82 83 84proc AtomNames {} { 85 global Alist 86 87 set Alist { X \ 88 H He Li Be B C N O \ 89 F Ne Na Mg Al Si P S \ 90 Cl Ar K Ca Sc Ti V Cr \ 91 Mn Fe Co Ni Cu Zn Ga Ge \ 92 As Se Br Kr Rb Sr Y Zr \ 93 Nb Mo Tc Ru Rh Pd Ag Cd \ 94 In Sn Sb Te I Xe Cs Ba \ 95 La Ce Pr Nd Pm Sm Eu Gd \ 96 Tb Dy Ho Er Tm Yb Lu Hf \ 97 Ta W Re Os Ir Pt Au Hg \ 98 Tl Pb Bi Po At Rn Fr Ra \ 99 Ac Th Pa U Np Pu Am Cm \ 100 Bk Cf Es Fm} 101 return $Alist 102} 103 104 105proc exit_pr {{arg {}}} { 106 global system 107 108 set button 1 109 if { $arg == {} } { 110 set button [tk_messageBox -message "Really quit?" \ 111 -type yesno -icon question] 112 } else { 113 # exit_pr -silent 114 set button yes 115 } 116 117 if { $button == "yes" } { 118 SetWatchCursor 119 if { ![file exists $system(SCRDIR)] } { 120 exit 0 121 } 122 123 catch "cd $system(PWD)" 124 125 clean_exit 126 } 127} 128 129 130proc clean_exit {{returnCode 0}} { 131 global system 132 if { [file isdirectory $system(SCRDIR)] } { 133 xcDebug -stderr "************************************************************************" 134 xcDebug -stderr "Deleting directory $system(SCRDIR) ; Please Wait !!!" 135 xcDebug -stderr "************************************************************************" 136 # we catch deleting, since on some strange NFS systems directory 137 # deletion will fail 138 if { ! [catch {file delete -force -- $system(SCRDIR)}] } { 139 xcDebug -stderr "Directory deleted !" 140 } else { 141 xcDebug -stderr "Failed to delete the directory !" 142 } 143 } 144 145 global exit_viewer_win 146 if { [info exists exit_viewer_win] } { 147 foreach win $exit_viewer_win { 148 if { [winfo exists $win] } { 149 bind $win <Destroy> {} 150 } 151 } 152 } 153 exit_tcl $returnCode 154} 155 156 157############################################################################# 158# this is the old routine for manipulating the font; the new one named 159# ModifyFont uses internal Tk "font" command 160proc ModifyFontSize {w size {arg {}}} { 161 global oldsize 162 163 # take care of $arg:: 164 if { $arg != {} } { 165 set foundry * 166 set family * 167 set weight * 168 set slant * 169 set i 0 170 foreach option $arg { 171 if { [regexp {^-} $option] } { 172 set tag $option 173 } else { 174 switch -- $tag { 175 "-foundry" {set foundry $option} 176 "-family" {set family $option} 177 "-weight" {set weight $option} 178 "-slant" {set slant $option} 179 default { 180 tk_dialog [WidgetName .a] Error \ 181 "ERROR: Bad option \"$tag\" submited to \n\ 182 ModifyFontSize procedure" 183 error 0 OK 184 return fixed 185 } 186 } 187 } 188 incr i 189 } 190 191 if { $i%2 } { 192 tk_dialog [WidgetName .a] Error \ 193 "ERROR: You called ModifyFontSize with an \n\ 194 odd number of args !" \ 195 error 0 OK 196 return fixed 197 } 198 set font "-$foundry-$family-$weight-$slant-*-*-$size-*" 199 } else { 200 set font [lindex [$w config -font] 3] 201 } 202 203 set fontlist [split $font -] 204 #xcDebug "Fontlist:: $fontlist" 205 206 if { [llength $fontlist] > 7 || $arg != {} } { 207 # X font name 208 # define first four fields; 209 set foundry [lindex [split $font -] 1] 210 set family [lindex [split $font -] 2] 211 set weight [lindex [split $font -] 3] 212 set slant [lindex [split $font -] 4] 213 214 set font [lindex $font 3] 215 216 #puts stdout "TTT:: $font" 217 #puts stdout "LLL:: -$foundry-$family-$weight-$slant-*-*-$size-*" 218 #first four fields + pixel fields are impotant for us 219 set done 1 220 if [catch {$w config -font \ 221 -$foundry-$family-$weight-$slant-*-*-$size-*}] { 222 set done 0 223 set upsize $size 224 set downsize $size 225 } else { 226 return "-$foundry-$family-$weight-$slant-*-*-$size-*" 227 } 228 229 for {} {$done != 1} {} { 230 # first try up, than try down 231 set upsize [expr $upsize + 1] 232 set downsize [expr $downsize - 1] 233 #puts "$upsize $downsize" 234 # maybe we have gone to far 235 if { $downsize == 0 || $upsize > [expr $size + 20]} { 236 # use default font 237 if [catch {$w config -font $font}] { 238 $w config -font TkFixedFont 239 return fixed 240 } else { 241 return $font 242 } 243 } 244 if {[catch {$w config -font \ 245 -$foundry-$family-$weight-$slant-*-*-$upsize-*}] == 0} { 246 return "-$foundry-$family-$weight-$slant-*-*-$upsize-*" 247 } elseif {[catch {$w config -font \ 248 -$foundry-$family-$weight-$slant-*-*-$downsize-*}] == 0} { 249 return "-$foundry-$family-$weight-$slant-*-*-$downsize-*" 250 } 251 } 252 } elseif { [llength $fontlist] == 2 } { 253 # maybe alias name is something like: {Helvetica -12 bold} 254 set oldsize [lindex [lindex $fontlist 1] 0] 255 #puts stdout "oldsize:: $oldsize" 256 if [number oldsize posint] { 257 #replace oldsize with size 258 set newfont \ 259 [concat [lindex $fontlist 0] -$size [lindex $fontlist 2]] 260 if [catch {$w config -font $newfont}] { 261 set done 0 262 set upsize $size 263 set downsize $size 264 } else { 265 return $newfont 266 } 267 268 for {} {$done != 1} {} { 269 # first try up, than try down 270 set upsize [expr $upsize + 1] 271 set downsize [expr $downsize - 1] 272 #puts "$upsize $downsize" 273 # maybe we have gone to far 274 if { $downsize == 0 || $upsize > [expr $size + 20]} { 275 # use default font 276 if [catch {$w config -font $font}] { 277 $w config -font TkFixedFont 278 return fixed 279 } else { 280 return $font 281 } 282 } 283 set upfont [concat [lindex $fontlist 0] -$upsize \ 284 [lindex $fontlist 2]] 285 set downfont [concat [lindex $fontlist 0] -$downsize \ 286 [lindex $fontlist 2]] 287 if {[catch {$w config -font $upfont}] == 0 } { 288 return $upfont 289 } elseif {[catch {$w config -font $downfont}] == 0 } { 290 return $downfont 291 } 292 } 293 } 294 } else { 295 # give up; use new Tk font Mechanism 296 set font [ModifyFont [$w cget -font] $w -size $size -default 1] 297 } 298} 299 300 301# 302# this is the new routine and uses Tk font mechanism 303# 304proc ModifyFont {font window {args {}}} { 305 global modifyFont 306 307 # allowed arguments:: 308 # -default ... create default font (0/1) (IGNORED) 309 # -family ... name 310 # -size ... size 311 # -weight ... weight 312 # -slant ... slant 313 # -underline ... boolean 314 # -overstrike ... boolean 315 316 # font actual font ?-displayof window? ?option? 317 set default 0 318 set family [font actual $font -displayof $window -family] 319 set size [font actual $font -displayof $window -size] 320 set weight [font actual $font -displayof $window -weight] 321 set slant [font actual $font -displayof $window -slant] 322 set underline [font actual $font -displayof $window -underline] 323 set overstrike [font actual $font -displayof $window -overstrike] 324 325 # take care of $arg:: 326 if { $args != {} } { 327 set i 0 328 foreach option $args { 329 if { [regexp {^-} $option] } { 330 set tag $option 331 } else { 332 switch -- $tag { 333 "-default" {set default $option} 334 "-family" {set family $option} 335 "-size" {set size $option} 336 "-weight" {set weight $option} 337 "-slant" {set slant $option} 338 "-underline" {set underline $option} 339 "-overstrike" {set overstrike $option} 340 default { 341 tk_dialog [WidgetName] Error \ 342 "ERROR: Bad option \"$tag\" submited to \n\ 343 ModifyFont procedure" error 0 OK 344 return fixed 345 } 346 } 347 } 348 incr i 349 } 350 351 if { $i%2 } { 352 tk_dialog [WidgetName] Error \ 353 "ERROR: You called ModifyFont with an \n\ 354 odd number of args !" \ 355 error 0 OK 356 return fixed 357 } 358 } 359 360 set new_font [font create] 361 362 font configure $new_font \ 363 -family $family \ 364 -size $size \ 365 -weight $weight \ 366 -slant $slant \ 367 -underline $underline \ 368 -overstrike $overstrike 369 return $new_font 370} 371 372proc SetFont {widtype args} { 373 set w [$widtype [WidgetName]] 374 set font [$w cget -font] 375 xcDebug -debug "SetFont: $font $w $args" 376 set Font [eval {ModifyFont $font $w} $args] 377 destroy $w 378 return $Font 379} 380 381# 382# this routine uses Tk font mechanism 383# 384proc GetFontAtribute {font window arg} { 385 386 # take care of $arg:: 387 if { [llength $arg] != 1 } { 388 tk_dialog [WidgetName] Error \ 389 "ERROR: You called GetFontAtribute with wrong \ 390 number of args !" \ 391 error 0 OK 392 return fixed 393 } 394 set tag [lindex $arg 0] 395 set option [lindex $arg 1] 396 switch -- $tag { 397 "-family" {return [font actual $font -displayof $window -family]} 398 "-size" {return [font actual $font -displayof $window -size]} 399 "-weight" {return [font actual $font -displayof $window -weight]} 400 "-slant" {return [font actual $font -displayof $window -slant]} 401 "-underline" { 402 return [font actual $font -displayof $window -underline]} 403 "-overstrike" { 404 return [font actual $font -displayof $window -overstrike]} 405 default { 406 tk_dialog [WidgetName .a] Error \ 407 "ERROR: Bad option \"$tag\" submited to \n\ 408 GetFontAtribute procedure" 409 error 0 OK 410 return 0 411 } 412 } 413} 414 415 416# # 417# # xcTkFontName2XLFD -- 418# # 419# # Tries to map TkFontName to XLFD X11 font name, if it does not 420# # succeed, then returns an empty string. 421# # 422# 423# proc xcTkFontName2XLFD {font} { 424# global tcl_platform 425# 426# if { $tcl_platform(platform) == "windows" } { 427# set fontAttr [font actual $font] 428# set font [font create] 429# eval {font configure $font} $fontAttr 430# return $font 431# } 432# 433# #puts stderr "*** xcTkFontName2XLFD : font = $font" 434# #puts stderr "*** xcTkFontName2XLFD : font actual font = [font actual $font]" 435# 436# # *** below is for X11 only:: 437# 438# # -------------------------------------------------- 439# # construct the font in the following form: 440# # -------------------------------------------------- 441# # -foundry-family-weight-slant-setwidth-addstyle-pixel-point-resx-resy-spacing-width-charset-encoding 442# # ------------------------------------------------------------------------ 443# 444# # -------------------------------------------------- 445# # Tk allowed fields 446# # -------------------------------------------------- 447# # -family name 448# # -size size 449# # -weight weight 450# # -slant slant 451# # -underline boolean 452# # -overstrike boolean 453# 454# foreach opt {family size weight slant} { 455# upvar 1 $opt var 456# set var [font actual $font -$opt] 457# set $opt $var 458# 459# # weight: 460# # normal = normal | regular | medium | book | light 461# # bold = bold | extrabold | demi | demibold 462# # 463# # slant: 464# # italic = i | o 465# 466# # if { $opt == "weight" } { 467# # if { $var == "normal" } { 468# # set weightList { medium normal regular book light } 469# # } else { 470# # set weightList { bold extrabold demi demibold } 471# # } 472# # } 473# # if { $opt == "slant" } { 474# # if { $var == "italic" } { 475# # set slantList { i o } 476# # } else { 477# # set slantList { r } 478# # } 479# # } 480# } 481# set XLFD_name "-*-$family-$weight-$slant-*-*-$size-*-*-*-*-*-*-*" 482# #puts stderr "*** xcTkFontName2XLFD : XLFD_name = $XLFD_name" 483# 484# return $XLFD_name 485# 486# # a hack for Mac OS X, which doesn't like negative sizes 487# 488# #global tcl_plaform 489# #if { $tcl_platform(os) == "Darwin" } { 490# # if { [string is integer $size] && $size < 0 } { 491# # set size [expr $size * (-1)] 492# # } 493# #} 494# # 495# #foreach weight $weightList { 496# # foreach slant $slantList { 497# # # example:: "-*-bookman-* -* -*-*-64 -*-*-*-*-*-*-*" 498# # set XLFD_name "-*-$family-$weight-$slant-*-*-$size-*-*-*-*-*-*-*" 499# # if { [xc_queryfont .mesa $XLFD_name] > 0 } { 500# # return $XLFD_name 501# # } 502# # } 503# #} 504# 505# # couldn't map tk-font-name --> XLFD name, return tk-font-name 506# #return $font 507# } 508 509 510 511proc AlwaysOnTopON {lower upperlist} { 512 xcDebug -debug "AlwaysOnTopON" 513 #there maybe more than one widget to raise 514 foreach upper $upperlist { 515 xcRaiseRegister $upper $lower 516 } 517 bind $lower <Button-1> [list xcRaise $lower] 518 bind $lower <Button-2> [list xcRaise $lower] 519 bind $lower <Button-3> [list xcRaise $lower] 520} 521 522 523proc xcRaiseRegister {upper lower} { 524 global xcRaise 525 # 526 # parse xcRaise($lower,toplevels) 527 # 528 if ![info exists xcRaise($lower,toplevels)] { 529 set xcRaise($lower,toplevels) {} 530 } 531 set new_list {} 532 foreach win $xcRaise($lower,toplevels) { 533 if { [winfo exists $win] && $win != $upper } { 534 append new_list "$win " 535 } 536 } 537 set xcRaise($lower,toplevels) [concat $new_list $upper] 538} 539 540 541proc xcRaise lower { 542 global xcRaise 543 # xcRaise($lower,toplevels) tells if there are some more toplevels 544 # to raise !!! 545 546 foreach widget $xcRaise($lower,toplevels) { 547 if { [winfo exists $widget] } { 548 raise $widget $lower 549 } 550 } 551 xcDebug -debug "$lower,xcRaise($lower,toplevels) $xcRaise($lower,toplevels)" 552} 553 554 555proc AlwaysOnTopOFF {{lower {.}}} { 556 puts stdout "AlwaysOnTopOFF" 557 bind $lower <Button-1> {} 558 bind $lower <Button-2> {} 559 bind $lower <Button-3> {} 560} 561 562 563proc CancelProc {w {var {}}} { 564 upvar $var varn 565 if { [winfo exists $w] } { 566 AlwaysOnTopOFF 567 catch { grab release $w } 568 destroy $w 569 } 570 set varn 0 571 #uplevel { return 0 } 572 return 0 573} 574 575# a simple wrapper to be used with widget "-command" 576proc DestroyWid w { 577 destroy $w 578} 579 580proc winGeom { w } { 581 # procedure determines the geometry of $w and return it 582 return [wm geometry $w] 583} 584 585 586############################################################################## 587# this proc read dimension & group (family) number out of GENGEOM file 588proc GetDimGroupXSF {dim group xsfFile} { 589 upvar $dim dm 590 upvar $group gr 591 set fileID [open $xsfFile r] 592 GetDimGroup dm gr $fileID 593 close $fileID 594} 595proc GetDimGroup {dim group fileID} { 596 upvar $dim dm 597 upvar $group gr 598 599 # <t.k.>: Thu Jul 13 15:13:57 CEST 2017 600 set dm 0 601 set gr 1 602 # </t.k.> 603 set n 0 604 set output [split [read $fileID] \n] 605 foreach line $output { 606 switch -regexp -- $line { 607 {^ *DIM-GROUP} { 608 set nn [expr $n + 1] 609 set dimgroup [lindex $output $nn] 610 set dm [lindex $dimgroup 0] 611 set gr [lindex $dimgroup 1] 612 xcDebug "GET-DIM-GROUP:: [lindex $dimgroup 0] [lindex $dimgroup 1]" 613 return 614 } 615 {^ *POLYMER} { 616 set dm 1 617 set gr 1 618 return 619 } 620 {^ *SLAB} { 621 set dm 2 622 set gr 1 623 return 624 } 625 {^ *CRYSTAL} { 626 set dm 3 627 set gr 1 628 return 629 } 630 } 631 incr n 632 } 633} 634 635 636# this proc is synonym for CellMode 637proc GenGeomDisplay {{update 0}} { 638 xcDebug "In GenGeomDisplay" 639 CellMode $update 640} 641 642 643############################################################################## 644# conversion between angstrom & bohr 645proc Bohr2Angs var { 646 global Const 647 return [expr $var * $Const(bohr)] 648} 649 650 651proc Angs2Bohr var { 652 global Const 653 return [expr $var / $Const(bohr)] 654} 655 656 657########################################################### 658#this proc generate a widget name that do not already exist 659proc WidgetName {{w {}}} { 660 set i 0 661 for {} {1} {} { 662 if [winfo exist $w.a$i] { 663 incr i 664 } else { 665 return $w.a$i 666 } 667 } 668} 669 670 671############################################################################## 672proc GetWidgetConfig {widget_com option} { 673 674 for {set i 1} {1} {incr i} { 675 if ![winfo exists .gwc$i] { 676 set w .gwc$i 677 break 678 } 679 } 680 681 $widget_com $w 682 set res [$w cget $option] 683 if { $option == "-background" || \ 684 $option == "-bg" || \ 685 $option == "-foreground" || \ 686 $option == "-fg" || \ 687 $option == "-activebackground" || \ 688 $option == "-activeforeground" || \ 689 $option == "-highlightbackground" || \ 690 $option == "-hightlightcolor" || \ 691 $option == "-disabledforeground" || \ 692 $option == "-insertbackground" || \ 693 $option == "-selectbackground" || \ 694 $option == "-selectcolor" || \ 695 $option == "-selectforeground" || \ 696 $option == "-troughcolor" } { 697 if { [string range $res 0 0] != "#" } { 698 set norm [lindex [winfo rgb . white] 0] 699 set rgb [winfo rgb . $res] 700 set res [format "#%02x%02x%02x" \ 701 [expr 256 * [lindex $rgb 0] / $norm] \ 702 [expr 256 * [lindex $rgb 1] / $norm] \ 703 [expr 256 * [lindex $rgb 2] / $norm]] 704 } 705 } 706 destroy $w 707 return $res 708} 709 710 711############################################################################## 712# return the filehead out of filename (file.poss --> file) 713proc FileHead file { 714 return [file rootname $file] 715} 716 717 718############################################################################## 719# return the possix out of filename (file.poss --> poss) 720proc FilePossix file { 721 set filename [split $file .] 722 set nfield [llength $filename] 723 set possix [lrange $filename [expr $nfield - 1] [expr $nfield - 1]] 724 725 return $possix 726} 727 728 729##################################### 730# used by, for example, DefaultButton 731proc DummyProc {{args {}}} { 732 return 733} 734 735 736############################################################### 737# if numbers specified in $args differ .leq. $limit -> return 1 738# else return 0 739proc IsEqual {limit args} { 740 741 set oldnum [lindex $args 1] 742 foreach num $args { 743 if { [expr abs($oldnum - $num)] >= $limit } { 744 return 0 745 } 746 set oldnum $num 747 } 748 749 return 1 750} 751 752############################################################################### 753# is a lower_or_equal to b (within $limit) 754proc IsLEQ {limit a b} { 755 756 if { $a <= [expr $b + $limit] } { 757 return 1 758 } else { 759 return 0 760 761 } 762} 763 764 765proc xcPause sec { 766 set iter [lindex [time { for {set i 1} {$i <= 10} {incr i} {update} }] 0] 767 set count [expr int(1e7 * $sec / $iter)] 768 xcDebug "xcPause:: $count" 769 for {set i 1} {$i < $count} {incr i} {update} 770} 771 772 773proc rgb_h2d rgb { 774 775 set len [string length $rgb] 776 # len can be 4,7,10,13 777 778 set i [expr $len / 3] 779 set norm 1 780 for {set n 1} {$n <= $i} {incr n} { 781 set norm [expr $norm * 16] 782 } 783 784 set r [string range $rgb 1 $i] 785 set g [string range $rgb [expr 1 + $i] [expr 2 * $i]] 786 set b [string range $rgb [expr 1 + 2 * $i] end] 787 788 set r [h2df $r] 789 set g [h2df $g] 790 set b [h2df $b] 791 792 return [list $r $g $b] 793} 794 795 796 797proc rgb_h2f rgb { 798 set len [string length $rgb] 799 # len can be 4,7,10,13 800 801 set i [expr $len / 3] 802 set norm 1 803 for {set n 1} {$n <= $i} {incr n} { 804 set norm [expr $norm * 16] 805 } 806 807 set r [string range $rgb 1 $i] 808 set g [string range $rgb [expr 1 + $i] [expr 2 * $i]] 809 set b [string range $rgb [expr 1 + 2 * $i] end] 810 811 set r [h2df $r $norm] 812 set g [h2df $g $norm] 813 set b [h2df $b $norm] 814 815 return [list $r $g $b] 816} 817 818 819proc rgb_f2h {rgba} { 820 set r [d2h [expr round([lindex $rgba 0] * 255)]] 821 set g [d2h [expr round([lindex $rgba 1] * 255)]] 822 set b [d2h [expr round([lindex $rgba 2] * 255)]] 823 824 return #${r}${g}${b} 825} 826 827 828proc rgb_f2d {rgba} { 829 # f is clamped float in range [0--1] 830 # returns decimal-list {255 255 255} 831 set r [expr round([lindex $rgba 0] * 255)] 832 set g [expr round([lindex $rgba 1] * 255)] 833 set b [expr round([lindex $rgba 2] * 255)] 834 return [list $r $g $b] 835} 836 837 838proc rgb_ac_f2h rgba { 839 # same as rgb_f2h, just to get color a little briter 840 841 set r [expr round([lindex $rgba 0] * 280)] 842 set g [expr round([lindex $rgba 1] * 280)] 843 set b [expr round([lindex $rgba 2] * 280)] 844 if { $r > 255 } {set r 255} 845 if { $g > 255 } {set g 255} 846 if { $b > 255 } {set b 255} 847 set r [d2h $r] 848 set g [d2h $g] 849 set b [d2h $b] 850 851 return #${r}${g}${b} 852} 853 854 855proc rgb_d2f {rgba} { 856 # f is clamped float in range [0--1] 857 # BEWARE: assuming rgba (INPUT) as {255 255 255} 858 set r [expr double([lindex $rgba 0]) / 255.0] 859 set g [expr double([lindex $rgba 1]) / 255.0] 860 set b [expr double([lindex $rgba 2]) / 255.0] 861 862 return [list $r $g $b] 863} 864 865 866proc h2df {h {norm 1}} { 867 # usage: h2df #rrggbb --> returns decimal-list, i.e., {255 255 255} 868 # usage: h2df #rrggbb 255 --> returns float-list, i.e. {1.0 1.0 1.0} 869 set d 0 870 set len [expr [string length $h] - 1] 871 for {set i $len} {$i >= 0} {incr i -1} { 872 set j [expr $len - $i] 873 switch -regexp -- [set a [string range $h $j $j]] { 874 [fF] {set a 15} 875 [eE] {set a 14} 876 [dD] {set a 13} 877 [cC] {set a 12} 878 [bB] {set a 11} 879 [aA] {set a 10} 880 } 881 set d [expr $d + $a * [xcOnPower 16 $i]] 882 } 883 if { $norm > 1.0 } { 884 return [expr double($d) / double($norm-1)] 885 } else { 886 return [expr int($d)] 887 } 888} 889 890 891proc d2h {num} { 892 set n1 [expr int( $num / 16 )] 893 set n2 [expr int($num) - $n1 * 16] 894 895 switch -exact -- $n1 { 896 15 {set n1 f} 897 14 {set n1 e} 898 13 {set n1 d} 899 12 {set n1 c} 900 11 {set n1 b} 901 10 {set n1 a} 902 } 903 904 switch -exact -- $n2 { 905 15 {set n2 f} 906 14 {set n2 e} 907 13 {set n2 d} 908 12 {set n2 c} 909 11 {set n2 b} 910 10 {set n2 a} 911 } 912 return [format "%s%s" $n1 $n2] 913} 914 915proc d2f {d} { 916 # BEWARE: assuming d (INPUT) in range [0,255] 917 # f is clamped float in range [0--1] 918 return [expr double([lindex $d 0]) / 255.0] 919} 920 921proc xcOnPower {a n} { 922 set res 1 923 for {set i 1} {$i <= $n} {incr i} { 924 set res [expr $res * $a] 925 } 926 return $res 927} 928 929 930##################### 931# set cursor to watch 932proc SetWatchCursor {} { 933 global xcCursor 934 foreach t [winfo children .] { 935 catch { puts stderr "SetWatchCursor: $t" } 936 if {"[info commands $t]" != {} } { 937 $t config -cursor $xcCursor(watch) 938 } 939 } 940 . config -cursor $xcCursor(watch) 941 CursorUpdate 942} 943 944proc CursorUpdate {} { 945 global xcCursor 946 if { [info exists xcCursor(dont_update)] } { 947 if { ! $xcCursor(dont_update) } { 948 update 949 } 950 } else { 951 update 952 } 953} 954 955####################### 956# set cursor to default 957proc ResetCursor {} { 958 global xcCursor 959 if { [info exists xcCursor(dont_update)] } { 960 if { $xcCursor(dont_update) } { 961 return 962 } 963 } 964 foreach t [winfo children .] { 965 if {"[info commands $t]" != {} } { 966 $t config -cursor $xcCursor(default) 967 } 968 } 969 CursorUpdate 970 . config -cursor $xcCursor(default) 971 #CursorUpdate 972} 973 974 975proc xcSwapBuffers {} { 976 if { [winfo exists .mesa] } { 977 update 978 xc_swapbuffer .mesa 979 } 980} 981 982 983############################################################################## 984# 985# Purpose: find out what is the name of fortran units (without number) 986# Return: the name of fortran UNIT 987proc FtnName {} { 988 global system 989 990 # create an empty $system(SCRDIR)/fort_unit/ directory 991 set pwd [pwd] 992 cd $system(SCRDIR) 993 if { [file exists fort_unit] } { 994 file delete -force fort_unit 995 } 996 file mkdir fort_unit 997 998 # cd to dirt_unit and run a simple fortran test 999 1000 cd fort_unit 1001 xcCatchExecReturn $system(FORDIR)/ftnunit 1002 update 1003 set file [glob -nocomplain *] 1004 regsub {\.99} $file {} ftn_name 1005 1006 # delete the fort_unit directory 1007 cd .. 1008 file delete -force fort_unit 1009 1010 cd $pwd 1011 return $ftn_name 1012 1013 # 1014 # this was the old routine 1015 # 1016 #set cwd [pwd] 1017 #cd $system(SCRDIR) 1018 #exec $system(FORDIR)/ftnunit 1019 #update 1020 #set file [file tail [lindex [glob -nocomplain $system(SCRDIR)/*99] 0]] 1021 #regsub 99 $file {} file 1022 #exec rm -f ${file}99 1023 #cd $cwd 1024 #return $file 1025} 1026 1027 1028# 1029# capitalizes the word 1030# 1031proc capitalize word { 1032 set w1 [string toupper [string range $word 0 0]] 1033 set w2 [string range $word 1 end] 1034 return [format %s%s $w1 $w2] 1035} 1036 1037 1038# 1039# return the filehead (filename without extension) 1040# 1041proc filehead {filename} { 1042 return [file rootname $filename] 1043} 1044 1045 1046proc WriteFile {filename content {flag w}} { 1047 global tcl_platform 1048 set fID [open $filename $flag] 1049 if { $tcl_platform(platform) == "windows" } { 1050 fconfigure $fID -translation {auto lf} 1051 } 1052 puts $fID $content 1053 flush $fID 1054 close $fID 1055} 1056 1057proc ReadFile {filename {arg {}}} { 1058 # Usage: ReadFile filename OR ReadFile -nonewline filename 1059 if { $arg != {} } { 1060 set filename $arg 1061 } 1062 set fID [open $filename r] 1063 if { $arg != {} } { 1064 set output [read -nonewline $fID] 1065 } else { 1066 set output [read $fID] 1067 } 1068 close $fID 1069 return $output 1070} 1071 1072proc GetAbsoluteFileName file { 1073 global system 1074 1075 # try this: 1076 return [file normalize [file join $system(PWD) $file]] 1077 1078 # if filename starts with / or ~ the absolute file name is assumed, 1079 # otherwise absolute filename should be: $system(PWD)/$file 1080 1081 #if { $file == "." } { 1082 # set file $system(PWD) 1083 #} 1084 #set file [string trimright $file /] 1085 #set c0 [string index $file 0] 1086 #if { $c0 == "/" || $c0 == "~" } { 1087 # return $file 1088 #} else { 1089 # return [file normalize [file join $system(PWD) $file]] 1090 #} 1091} 1092 1093#----------------------------------------- 1094# convert angstrom unit to fractional unit 1095proc GetFracCoor {coor} { 1096#----------------------------------------- 1097 global system 1098 1099 set x [lindex $coor 0] 1100 set y [lindex $coor 1] 1101 set z [lindex $coor 2] 1102 1103 xcDebug -debug "exec $system(BINDIR)/fracCoor \ 1104 $system(SCRDIR)/xc_struc.$system(PID) $x $y $z" 1105 1106 if { [catch {set coor [exec $system(BINDIR)/fracCoor $system(SCRDIR)/xc_struc.$system(PID) $x $y $z]} errmsg] } { 1107 ErrorDialog "error occured while executing \"fracCoor\" program.\n\nError Message:\n$errmsg" 1108 xcDebug -debug "GetFracCoor: $coor" 1109 return {0.0 0.0 0.0} 1110 } 1111 1112 xcDebug -debug "GetFracCoor: $coor" 1113 return $coor 1114} 1115 1116# ----------------------------------------------- 1117# convert coordinates from Angstrom to $unit unit 1118proc coorToUnit {unit x y z} { 1119 # unit must be one of: angs bohr prim conv alat 1120 global Const 1121 1122 switch -- $unit { 1123 bohr { 1124 return [list [expr $x / $Const(bohr)] [expr $y / $Const(bohr)] [expr $z / $Const(bohr)]] 1125 } 1126 prim - conv { 1127 return [xc_fractcoor -ctype $unit -coor [list $x $y $z]] 1128 } 1129 alat { 1130 global mody 1131 set alat [xc_getvalue $mody(GET_ALAT)] 1132 return [list [expr $x / $alat] [expr $y / $alat] [expr $z / $alat]] 1133 } 1134 angs - default { 1135 return [list $x $y $z] 1136 } 1137 } 1138} 1139 1140 1141############################################################################## 1142# DEBUGING 1143proc xcDebug {line {args {}}} { 1144 global xcMisc 1145 1146 set channel stdout 1147 if { $line == "-stderr" } { 1148 set channel stderr 1149 set line [string trim $args \{\}] 1150 } elseif { $line == "-debug" && $xcMisc(debug) == 1 } { 1151 set channel stderr 1152 set line [string trim $args \{\}] 1153 } 1154 if ![catch {puts $channel $line}] { 1155 flush $channel 1156 } 1157} 1158 1159 1160proc xcEditFile {file {foreground 0}} { 1161 global env system 1162 1163 if { [info exists env(EDITOR)] && [info exists system(term)] } { 1164 if { $foreground != 0 } { 1165 exec $system(term) -e $env(EDITOR) $file 1166 } else { 1167 exec $system(term) -e $env(EDITOR) $file & 1168 } 1169 } else { 1170 if { $foreground != 0 } { 1171 tkwait window [defaultEditor $file] 1172 } else { 1173 defaultEditor $file 1174 } 1175 } 1176} 1177 1178 1179 1180proc xcDeleteAllChildren {wlist} { 1181 1182 foreach w $wlist { 1183 if ![winfo exists $w] continue 1184 set children [winfo children $w] 1185 if { $children != "" } { 1186 foreach child $children { 1187 xcDeleteAllChildren $child 1188 catch [destroy $child] 1189 } 1190 } 1191 } 1192} 1193 1194 1195proc gunzipFile {file} { 1196 global system 1197 1198 xcDebug -debug "gunzipFile: $file" 1199 1200 #################### 1201 set gunzipName $file 1202 #################### 1203 1204 set name [file tail $file] 1205 1206 if { [file extension $name] == ".gz" } { 1207 1208 set here [pwd] 1209 cd $system(SCRDIR) 1210 1211 # maybe file is already located in $system(SCRDIR); if not copy it there 1212 if { [file dirname $file] != $system(SCRDIR) && $file != $name } { 1213 file copy -force $file $name 1214 } 1215 1216 catch {exec -- gzip -df $name} 1217 set gunzipName [file rootname $name] 1218 if { ![file exists $gunzipName] } { 1219 tk_dialog [WidgetName] "ERROR" \ 1220 "ERROR: error when gunzip-ing file $file" warning 0 OK 1221 uplevel 1 { return } 1222 } 1223 set gunzipName $system(SCRDIR)/$gunzipName 1224 1225 cd $here 1226 } 1227 1228 return $gunzipName 1229} 1230 1231# Purpose: clean a welcome window 1232proc destroyWelcome {} { 1233 if { [winfo exists .title] } { 1234 # destroy WELCOME window 1235 destroy .title 1236 } 1237} 1238 1239 1240proc ErrorDialogInfo {text {errMsg {}}} { 1241 destroyWelcome 1242 #error $text 1243 set id [tk_dialog [WidgetName] ERROR "ERROR: $text." error 0 OK ErrorInfo] 1244 if { $id == 1 } { 1245 tkwait window [xcDisplayVarText $errMsg "Error Info"] 1246 } 1247} 1248 1249 1250# Purpose: do exec and report an error upon failure 1251# Return: 0 on success, 1 on failure 1252proc xcCatchExec {args} { 1253 destroyWelcome 1254 xcDebug -stderr "Executing: $args" 1255 if { [catch {eval exec $args} errMsg] } { 1256 ErrorDialogInfo "while executing\nexec $args" $errMsg 1257 return 1 1258 } 1259 return 0 1260} 1261 1262# same as xcCatchExec but with redirection of stdout/stderr !!! 1263proc xcCatchExecRedirectStdErr {args} { 1264 destroyWelcome 1265 xcDebug -stderr "Executing: $args" 1266 if { [catch {eval exec $args 2> /dev/null} errMsg] } { 1267 ErrorDialogInfo "while executing\nexec $args" $errMsg 1268 return 1 1269 } 1270 return 0 1271} 1272 1273proc xcCatchExecReturn {args} { 1274 destroyWelcome 1275 xcDebug -stderr "Executing: $args" 1276 1277 SetWatchCursor 1278 if { [catch {eval exec $args} errMsg] } { 1279 ErrorDialogInfo "while executing\nexec $args" $errMsg 1280 ResetCursor 1281 uplevel 1 { 1282 return 1 1283 } 1284 } 1285 ResetCursor 1286 1287 return 0 1288} 1289 1290 1291# same as xcCatchExecReturn but with redirection of stdout/stderr !!! 1292proc xcCatchExecReturnRedirectStdErr {args} { 1293 destroyWelcome 1294 xcDebug -stderr "Executing: $args" 1295 if { [catch {eval exec $args 2> /dev/null} errMsg] } { 1296 ErrorDialogInfo "while executing\nexec $args" $errMsg 1297 uplevel 1 { 1298 return 1 1299 } 1300 } 1301 return 0 1302} 1303 1304proc ErrorDialog {text {errMsg {}}} { 1305 destroyWelcome 1306 set text "ERROR: $text." 1307 if { $errMsg != "" } { 1308 append text "\n\nError Mesage:\n$errMsg" 1309 } 1310 tk_messageBox -title ERROR -message $text -type ok -icon error 1311} 1312 1313proc WarningDialog {text {warnMsg {}}} { 1314 if { [winfo exists .title] } { 1315 # destroy WELCOME window 1316 destroy .title 1317 } 1318 set text "WARNING: $text" 1319 if { $warnMsg != "" } { 1320 append text "\n\nWarning Mesage:\n$warnMsg" 1321 } 1322 tk_messageBox -title WARNING -message $text -type ok -icon warning 1323} 1324 1325proc ErrorIn {where text} { 1326 tk_messageBox -title ERROR -message "ERROR: $text\n\nThis error was triggered from $where procedure" -type ok -icon error 1327} 1328 1329 1330# 1331# xcSkipEmptyLines -- 1332# 1333# Purpose: skip empty lines from the variable content 1334proc xcSkipEmptyLines {text} { 1335 foreach line [split $text \n] { 1336 if { [regexp -- {\w} $line] } { 1337 append out [format "%s\n" $line] 1338 } 1339 } 1340 return $out 1341} 1342 1343 1344# ------------------------------------------------------------------------ 1345# evaluate the Tcl commands within the catch command and if error occurs 1346# prints the errorMsg. If errorMsg is void, than prints the error message 1347# returned by the Catch command. 1348# ------------------------------------------------------------------------ 1349proc xcCatchEval {cmd {errorMsg {}}} { 1350 1351 if { [catch {eval $cmd} _errorMsg] } { 1352 if { $errorMsg == "" } { 1353 set errorMsg $_errorMsg 1354 } else { 1355 append errorMsg "\n$_errorMsg" 1356 } 1357 ErrorDialog "An ERROR occured while executing:\n$cmd\n\nERROR MESSAGE: $errorMsg" 1358 } 1359} 1360 1361 1362# ------------------------------------------------------------------------ 1363#****f* Scripting/repeat 1364# 1365# NAME 1366# repeat 1367# 1368# USAGE 1369# repeat ntimes script 1370# 1371# PURPOSE 1372 1373# This proc is for repetitive execution of a script supllied by 1374# "script" argument. For example: 1375# 1376# repeat 10 { puts "Hello !!!" } 1377# 1378# will print "Hello !!!" 10-times. The repeat is nothing else then 1379# simplified "for" loop. Above example could be also achieved by: 1380# 1381# for {set i 0} {$i < 10} {incr i} { 1382# puts "Hello !!!" 1383# } 1384# 1385 1386# 1387# SIDE EFFECTS 1388# Inside repeat scripts, the "repeat" variable have the value of the current 1389# repeat-iteration. For example: 1390# 1391# repeat 4 { puts "This is the $repeat. iteration !!!" } 1392# 1393# will print: 1394# 1395# This is the 1. iteration 1396# This is the 2. iteration 1397# This is the 3. iteration 1398# This is the 4. iteration 1399 1400# 1401# ARGUMENTS 1402# ntimes -- how many times to execute a script 1403# script -- script to execute 1404# 1405# RETURN VALUE 1406# Undefined. 1407# 1408# EXAMPLE 1409# repeat 10 { 1410# scripting::rotate x 5 1411# scripting::makeMovie::makeFrame 1412# } 1413# 1414# SOURCE 1415 1416proc repeat {ntimes script} { 1417 global repeat_script repeat 1418 1419 set repeat_script $script 1420 for {set repeat 1} {$repeat <= $ntimes} {incr repeat} { 1421 uplevel 1 {eval $repeat_script} 1422 } 1423} 1424#**** 1425# ------------------------------------------------------------------------ 1426 1427 1428# ------------------------------------------------------------------------ 1429#****f* Scripting/wait 1430# 1431# NAME 1432# wait 1433# 1434# USAGE 1435# wait ms 1436# 1437# PURPOSE 1438# This proc is similar to the Tcl command "after ms". However before 1439# waiting for period of ms milliseconds, it updates all the events 1440# (the after command does not make the update before waiting !!!) 1441# 1442# ARGUMENTS 1443# ms -- waiting time in milliseconds 1444# 1445# RETURN VALUE 1446# Undefined. 1447# 1448# EXAMPLE 1449# wait 500 1450# 1451# SOURCE 1452 1453proc wait {ms} { 1454 if { ! [string is integer $ms] } { 1455 ErrorIn wait "expected integer, but got $ms" 1456 return 1457 } 1458 update 1459 after $ms 1460} 1461#**** 1462# ------------------------------------------------------------------------ 1463 1464proc positiveInteger {string} { 1465 if { ![string is integer $string] } { 1466 return 0 1467 } elseif { $string <= 0 } { 1468 return 0 1469 } else { 1470 return 1 1471 } 1472} 1473 1474proc nonnegativeInteger {string} { 1475 if { ![string is integer $string] } { 1476 return 0 1477 } elseif { $string < 0 } { 1478 return 0 1479 } else { 1480 return 1 1481 } 1482} 1483 1484 1485# return 1 if string is the OpenGL RGBA color spec, 0 otherwise 1486proc rgba {string} { 1487 if { [llength $string] != 4 } { 1488 return 0 1489 } 1490 for {set i 0} {$i < 4} {incr i} { 1491 set v [lindex $string $i] 1492 if { ! [string is double $v] } { 1493 return 0 1494 } elseif { $v > 1.0 || $v < 0.0 } { 1495 return 0 1496 } 1497 } 1498 return 1 1499} 1500 1501 1502proc allowedValue {value allowedValues} { 1503 # returns 1 if $value is among item in $allowedValues list 1504 1505 foreach item $allowedValues { 1506 if { $value == $item } { 1507 return 1 1508 } 1509 } 1510 return 0 1511} 1512 1513proc destroyWelcomeWindow {} { 1514 if { [winfo exists .title] } { 1515 destroy .title 1516 } 1517} 1518 1519 1520proc xcTempFile {name} { 1521 global system 1522 return $system(SCRDIR)/$name.$system(PID) 1523} 1524 1525 1526# 1527# evalInScratch -- evaluate the script in SCRATCH, i.e. $system(SCRDIR), directory 1528# 1529proc evalInScratch {script} { 1530 global system 1531 1532 set here [pwd] 1533 cd $system(SCRDIR) 1534 uplevel 1 [list eval $script] 1535 cd $here 1536} 1537 1538# 1539# evalInDir -- evaluate the script in $dir directory 1540# 1541proc evalInDir {dir script} { 1542 set here [pwd] 1543 cd $dir 1544 uplevel 1 eval $script 1545 cd $here 1546} 1547 1548 1549# evalInPWD -- This is a workaround routine: the code does many times 1550# "cd $system(SCRDIR)", hence the real pwd is lost. There is a global 1551# $system(PWD), but for example user might change in scripting-scripts 1552# the cd then his [pwd] is lost as system(PWD) was not updated. This 1553# routine execute the code either in [pwd], but if [pwd] == 1554# $system(SCRDIR), then it executes the code in $system(PWD) 1555# 1556proc evalInPWD {script} { 1557 global system 1558 set here [pwd] 1559 if { $here != $system(SCRDIR) } { 1560 cd $here 1561 } else { 1562 cd $system(PWD) 1563 } 1564 uplevel 1 eval $script 1565 cd $here 1566} 1567 1568 1569#------------------------------------------------------------------------ 1570#****f* auxil/putsFlush 1571# NAME 1572# putsFlush -- Tcl "puts" + "flush" 1573# USAGE 1574# putsFlush ?-nonewline? ?channelId? string 1575# 1576# DESCRIPTION 1577# Identical to Tcl's puts, but invoke the flush immediately after. 1578# See puts man-page of Tcl. 1579#******** 1580#------------------------------------------------------------------------ 1581 1582proc putsFlush {args} { 1583 update; update idletask 1584 # puts ?-nonewline? ?channelId? string 1585 set ind 0 1586 set flags "" 1587 if { [lindex $args $ind] == "-nonewline" } { 1588 set flags "-nonewline" 1589 incr ind 1590 } 1591 if { [llength [lrange $args $ind end]] == 1 } { 1592 set channel stdout 1593 } else { 1594 set channel [lindex $args $ind] 1595 incr ind 1596 } 1597 1598 eval puts $flags $channel [lrange $args $ind end] 1599 flush $channel 1600} 1601 1602# 1603# Tcl's file copy will copy the link instead of the file. If link has 1604# a relative filename value, that's will be a mass: correct for this. 1605# 1606proc fileCopy {src dst} { 1607 1608 catch {set file [file readlink $src]} 1609 1610 if { [info exists file] } { 1611 global system 1612 return [file copy -force [file join $system(PWD) $file] $dst] 1613 } else { 1614 return [file copy -force $src $dst] 1615 } 1616} 1617 1618proc lineRead {var file script} { 1619 # PURPOSE 1620 # Read entire file line-by-line and at each line execute a 1621 # script at one level up. 1622 # ARGUMENTS 1623 # * var -- name of variable where the content of line will be stored 1624 # * file -- name of file to read 1625 # * script -- script to execute when line is read 1626 # 1627 # CREDITS 1628 # Based on fileutils::foreachLine from tcllib (almost verbatim). 1629 # SOURCE 1630 upvar $var line 1631 1632 set fid [open $file r] 1633 set code 0 1634 set result {} 1635 1636 while { ! [eof $fid] } { 1637 gets $fid line 1638 set code [catch {uplevel 1 $script} result] 1639 if {($code != 0) && ($code != 4)} { 1640 break 1641 } 1642 } 1643 close $fid 1644 1645 if { ($code == 0) || ($code == 3) || ($code == 4) } { 1646 return $result 1647 } 1648 if { $code == 1 } { 1649 global errorCode errorInfo 1650 return \ 1651 -code $code \ 1652 -errorcode $errorCode \ 1653 -errorinfo $errorInfo \ 1654 $result 1655 } 1656 return -code $code $result 1657} 1658 1659 1660 1661 1662# Purpose: returns all the descendents of the given window (including 1663# itself) 1664proc getAllDescendantWid {w} { 1665 global getAllDescendantWid_list 1666 1667 if { [info exists getAllDescendantWid_list] } { 1668 set getAllDescendantWid_list "" 1669 } 1670 1671 return [getAllDescendantWid_ $w] 1672} 1673proc getAllDescendantWid_ {wlist} { 1674 global getAllDescendantWid_list 1675 1676 foreach w $wlist { 1677 if { ![winfo exists $w] } continue 1678 1679 lappend getAllDescendantWid_list $w 1680 1681 set children [winfo children $w] 1682 1683 if { $children != "" } { 1684 foreach child $children { 1685 getAllDescendantWid_ $child 1686 } 1687 } 1688 } 1689 return $getAllDescendantWid_list 1690} 1691 1692 1693# set a variable only if it does not exist 1694proc ifset {varName value} { 1695 upvar 1 $varName var 1696 1697 if { ! [info exists var] } { 1698 uplevel 1 $script 1699 } 1700} 1701