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