source: trunk/cifselect.tcl @ 640

Last change on this file since 640 was 640, checked in by toby, 11 years ago

# on 2002/08/09 16:44:11, toby did:
Used to select distances & angles for "publication" in CIF

  • Property rcs:author set to toby
  • Property rcs:date set to 2002/08/09 16:44:11
  • Property rcs:rev set to 1.1
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 17.3 KB
Line 
1# a set of procedures to implement CIFselect:
2# publication flags for distances and angles
3
4# create a label for an atom
5proc labelatom {phase atom} {
6    global labelarr
7    set a [lindex [split $atom _] 0]
8    set suffix [lindex [split $atom _] 1]
9    set label ${a}
10    catch {
11        set label $labelarr(${phase}P${a})
12    }
13    if {$suffix != ""} {
14        append label _$suffix
15    }
16    return $label
17}
18
19# create a symmetry code number (a-zz for 1 to 702 [26*27])
20proc codenumber {n} {
21    set res {}
22    while {$n > 0} {
23        set c [format %c [expr {97 + ($n-1) % 26}]]
24        set res "${c}${res}"
25        set n [expr {($n - 1) / 26}]
26    }
27    return $res
28}
29
30# format numbers & errors in crystallographic notation
31proc formatSU {num err} {
32    # errors less or equal to t are expressed as 2 digits
33    set T 19
34    set lnT [expr { log10($T) }] 
35    # error is zero
36    if {$err == 0} {
37        # is this an integer?
38        if {int($num) == $num} {
39            return [format %d [expr int($num)]]
40        }
41        # allow six sig figs with a zero error (except for 0.0)
42        set dec [expr int(5.999999-log10( abs($num) ))]
43        if {$dec < -2 || $dec > 9} {
44            return [format %.5E $num]
45        } elseif {$dec <= 0} {
46            return [format %d [expr int($num)]]
47        } else {
48            return [format %.${dec}f $num]
49        }
50    } else {
51        #set sigfigs [expr log10( abs(10) / abs(.012/$T) ) + 1]
52        # should the number be expressed in scientific notation?
53        if {$err > $T || abs($num) < 0.0001} {
54            # get the exponent
55            set exp [lindex [split [format %E $num] E] end]
56            # strip leading zeros
57            regsub {([-\+])0+} $exp {\1} exp
58            # number of decimals in exponetial notation
59            set dec [expr int($lnT - log10( abs($err) ) + $exp)]
60            # should the error be displayed?
61            if {$err < 0} {
62                return [format "%.${dec}E" $num]
63            } else {
64                # scale the error into a decimal number
65                set serr [expr int(0.5 + $err * pow(10,$dec-$exp))]
66                return [format "%.${dec}E(%d)" $num $serr]
67            }
68        } else {
69            # number of digits
70            set dec [expr int($lnT - log10( abs($err) ))]
71            # should the error be displayed?
72            if {$err < 0} {
73                return [format "%.${dec}f" $num]
74            } else {
75                set serr [expr int(0.5 + $err * pow(10,$dec))]
76                return [format "%.${dec}f(%d)" $num $serr]
77            }
78        }
79    }
80}
81
82
83# fill a frame with distances and angles as a trianglar matrix
84proc FillDistAngMatrix {phase atom} {
85    global disarr dislist disflag angarr angflag widget CIFselect
86    catch {unset widget}
87    set frame $CIFselect(seldisplay)
88    eval destroy [winfo children $frame]
89    set width 0
90
91    # overall heading
92    grid [frame $frame.head] \
93            -row 0 -col 0 -columnspan 99 -sticky ew
94    grid [label $frame.head.l -textvariable CIFselect(boxhead)\
95            -anchor center] \
96            -row 0 -col 0 -sticky ew
97    set CIFselect(boxhead) "Select an atom for distance and angle display"
98    grid columnconfigure $frame.head 0 -weight 1 -pad 10
99    grid [button $frame.head.help -text Help -bg yellow \
100            -command "MakeWWWHelp gsas2cif.html cifselect"] \
101            -column 1 -row 0 -sticky e
102
103    if {$phase == "" || $atom == ""} return
104
105    # make a list of atoms involved in angles
106    set alist {}
107    foreach a [array names angarr ${phase}P${atom}:*] {
108        foreach {c i j} [split $a :] {}
109        if {[lsearch $alist $i] == -1} {lappend alist $i}
110        if {[lsearch $alist $j] == -1} {lappend alist $j}
111    }
112    set alist [lsort $alist]
113    # make a list of atoms in distances
114    set dlist $dislist(${phase}P$atom)
115   
116    # set overall heading
117    set CIFselect(boxhead) \
118            "Distances and angles around atom [labelatom $phase $atom]"
119
120    grid [frame $frame.a] -row 1 -col 0 -columnspan 99
121    foreach {tbox bbox sbox cbox} [MakeScrollTable $frame.a] {}
122    [winfo parent $bbox] config -width 550 -height 300
123   
124    # column labels
125    set row 0
126    grid [label $tbox.$row-2 -text distance \
127                -width $width] -row $row -col 2
128    set col 3
129    foreach l $alist {
130        # skip last entry
131        if {$l == [lindex $alist end]} continue
132        incr col
133        grid [label $tbox.$row-$col -text [labelatom $phase $l] \
134                -width $width] -row $row -col $col
135        incr col
136    }
137
138    # angle/distance entries
139    set i -1
140    set row -1
141    foreach l $alist {
142        incr row
143        set col 0
144        grid [label $sbox.$row-l -text [labelatom $phase $l]] \
145                -row $row -col $col
146        incr col 2
147        set dist [eval formatSU $disarr(${phase}P${atom}:$l)]
148        grid [label $bbox.$row-d -text $dist -width $width] \
149                -row $row -col $col -sticky ew
150        ColorWidget $bbox.$row-d $disflag(${phase}P${atom}:$l)
151        set widget($bbox.$row-d) ${phase}P${atom}:$l
152       
153        foreach a [lrange $alist 0 $i] {
154            set angle {}
155            catch {
156                set angle $angarr(${phase}P${atom}:$l:$a)
157                set index ${phase}P${atom}:$l:$a
158            }
159            catch {
160                set angle $angarr(${phase}P${atom}:$a:$l)
161                set index ${phase}P${atom}:$a:$l
162            }
163            if {$angle != ""} {
164                set atxt [eval formatSU $angle]
165                incr col 2
166                grid [label $bbox.$row-$col -text $atxt -width $width] \
167                        -row $row -col $col -sticky ew
168                ColorWidget $bbox.$row-$col $angflag($index)
169                set widget($bbox.$row-$col) $index
170            } else {
171                incr col
172            }
173        }
174        incr i
175    }
176    foreach l [lsort $dlist] {
177        if {[lsearch $alist $l] != -1} continue
178        incr row
179        set col 0
180        grid [label $sbox.$row-l -text [labelatom $phase $l]] \
181                -row $row -col $col
182        set dist [eval formatSU $disarr(${phase}P${atom}:$l)]
183        incr col 2
184        grid [label $bbox.$row-d -text $dist -width $width] \
185                -row $row -col $col -sticky ew
186        ColorWidget $bbox.$row-d $disflag(${phase}P${atom}:$l)
187        set widget($bbox.$row-d) ${phase}P${atom}:$l
188    }
189    foreach n [array names widget] {
190        bind $n <1> {SetWidgetFlag %W}
191    }
192
193    #grid columnconfigure $bbox 1 -minsize 5
194    #grid columnconfigure $tbox 1 -minsize 5
195    set col 3
196    foreach l $alist {
197        # skip last entry
198        if {$l == [lindex $alist end]} continue
199        grid columnconfigure $bbox $col -minsize 5
200        grid columnconfigure $tbox $col -minsize 5
201        incr col 2
202    }
203    update
204    ResizeScrollTable $frame.a
205    update
206    ExpandScrollTable $frame.a
207}
208
209# create a file with all distances and angles as a trianglar matrix
210proc ExportDistAngMatrix {} {
211    global disarr dislist disflag angarr angflag widget CIFselect expmap
212    set phase $CIFselect(phase)
213    if {$phase == ""} return
214
215    set file [tk_getSaveFile \
216            -filetypes {{spreadsheet .csv}} -defaultextension .csv \
217            -parent .]
218    if {$file == ""} return
219    set fp [open $file w]
220    # overall heading
221    puts $fp "Distances and angles around atoms in phase $phase"
222
223    foreach atom $expmap(atomlist_$phase) {
224
225        # make a list of atoms involved in angles
226        set alist {}
227        foreach a [array names angarr ${phase}P${atom}:*] {
228            foreach {c i j} [split $a :] {}
229            if {[lsearch $alist $i] == -1} {lappend alist $i}
230            if {[lsearch $alist $j] == -1} {lappend alist $j}
231        }
232        set alist [lsort $alist]
233        # make a list of atoms in distances
234        set dlist $dislist(${phase}P$atom)
235   
236        # atom heading
237        puts $fp "\nDistances and angles around atom [labelatom $phase $atom]"
238
239        # column labels
240        puts -nonewline $fp ",distance"
241        foreach l $alist {
242            # skip last entry
243            if {$l == [lindex $alist end]} continue
244            puts -nonewline $fp ",[labelatom $phase $l]"
245        }
246        puts $fp ""
247       
248        # angle/distance entries
249        set i -1
250        foreach l $alist {
251            set dist [eval formatSU $disarr(${phase}P${atom}:$l)]
252            puts -nonewline $fp "[labelatom $phase $l],$dist"
253            foreach a [lrange $alist 0 $i] {
254                set angle {}
255                catch {
256                    set angle $angarr(${phase}P${atom}:$l:$a)
257                }
258                catch {
259                    set angle $angarr(${phase}P${atom}:$a:$l)
260                }
261                if {$angle != ""} {
262                    set atxt [eval formatSU $angle]
263                    puts -nonewline $fp ",$atxt"
264                }
265            }
266            puts $fp ""
267            incr i
268        }
269    }
270
271    foreach l [lsort $dlist] {
272        if {[lsearch $alist $l] != -1} continue
273        set dist [eval formatSU $disarr(${phase}P${atom}:$l)]
274        puts $fp "[labelatom $phase $l],$dist"
275    }
276    close $fp
277}
278
279# set the color for a distance/angle entry
280proc ColorWidget {widget flag} {
281    if {$flag} {
282        $widget config -bg yellow
283    } else {
284        $widget config -bg white
285    }
286}
287
288# respond to a mouse click on a distance or angle label
289proc SetWidgetFlag {W} {
290    global widget CIFselect angflag disflag
291    set index $widget($W)
292    # angle or distance?
293    incr CIFselect(changes)
294    if {[regexp {[0-9]P[0-9]+:.+:.+} $index]} {
295        # angle
296        if {$CIFselect(click) == "set"} {
297            set angflag($index) 1
298        } elseif {$CIFselect(click) == "clear"} {
299            set angflag($index) 0
300        } else {
301            set angflag($index) [expr ! $angflag($index)]
302        }
303        ColorWidget $W $angflag($index)
304    } else {
305        # distance
306        if {$CIFselect(click) == "set"} {
307            set disflag($index) 1
308        } elseif {$CIFselect(click) == "clear"} {
309            set disflag($index) 0
310        } else {
311            set disflag($index) [expr ! $disflag($index)]
312        }
313        ColorWidget $W $disflag($index)
314        if {$CIFselect(select) == "yes"} {
315            # get atom
316            set atom [lindex [split $index :] end]
317            foreach n [array names widget] {
318                set aindex $widget($n)
319                foreach {c i j} [split $aindex :] {}
320                # reject distances
321                if {$j == ""} continue
322                if {$i == $atom || $j == $atom} {
323                    if {$disflag(${c}:$j) && $disflag(${c}:$i)} {
324                        set angflag($aindex) 1
325                        ColorWidget $n 1
326                    } else {
327                        set angflag($aindex) 0
328                        ColorWidget $n 0
329                    }
330                }
331            }
332        }
333    }
334}
335
336# respond to a selection of a phase
337proc SelectPhase {} {
338    global CIFselect expmap
339    $CIFselect(atomlist) delete 0 end
340    foreach atom $expmap(atomlist_$CIFselect(phase)) {
341        $CIFselect(atomlist) insert end [atominfo $CIFselect(phase) $atom label]
342    }
343    FillDistAngMatrix "" "" 
344}
345
346# respond to the selection of an angle
347proc SelectAtom {} {
348    global CIFselect expmap
349    # get selected atom
350    set atomnum [lindex $expmap(atomlist_$CIFselect(phase)) \
351            [$CIFselect(atomlist) curselection]]
352    FillDistAngMatrix $CIFselect(phase) $atomnum
353}
354
355# resize the window
356proc ConfigureCommand {win frame} {
357    set cmd [bind $win <Configure>]
358    if {$cmd == ""} return
359    bind $win <Configure> {}
360    update
361    if {[winfo exists $frame]} {ExpandScrollTable $frame}
362    update idletasks
363    after idle "bind $win <Configure> [list $cmd]"
364}
365
366# write the distance & angle flags to a file
367proc SaveFlags {expnam} {
368    global symlist disflag angflag CIFselect   
369    file rename -force ${expnam}.DISAGL ${expnam}.DISold
370    set fp [open ${expnam}.DISold r]
371    set out [open ${expnam}.DISAGL w]
372    gets $fp line
373    puts $out $line
374    while {[gets $fp line] >= 0} {
375        set phase [lindex $line 1]
376        if {[lindex $line 2] == 0} {
377            # distance
378            set center [lindex $line 5]
379            set a1 [lindex $line 6]
380            set a1l ${phase}P$a1
381            set sym [lindex $line 7]_[lindex $line 8]
382            set i [lsearch $symlist($a1l) $sym]
383            incr i
384            set atom1 ${a1}_[codenumber $i]
385            catch {
386                if {$disflag(${phase}P${center}:$atom1)} {
387                    set line [string replace $line 0 0 Y]
388                } else {
389                    set line [string replace $line 0 0 N]
390                }
391            }
392        } elseif {[lindex $line 2] == 1} {
393            # angle
394            set center [lindex $line 6]
395            set a1 [lindex $line 5]
396            set a1l ${phase}P$a1
397            set a2 [lindex $line 7]
398            set a2l ${phase}P$a2
399            set sym1 [lindex $line 8]_[lindex $line 9]
400            set sym2 [lindex $line 10]_[lindex $line 11]
401            set i [lsearch $symlist($a1l) $sym1]
402            incr i
403            set atom1 ${a1}_[codenumber $i]
404            set i [lsearch $symlist($a2l) $sym2]
405            incr i
406            set atom2 ${a2}_[codenumber $i]
407            catch {
408                if {$angflag(${phase}P${center}:${atom1}:${atom2})} {
409                    set line [string replace $line 0 0 Y]
410                } else {
411                    set line [string replace $line 0 0 N]
412                }
413            }
414        }
415        puts $out $line
416    }
417    close $fp
418    close $out
419}
420
421# respond to the Exit button
422proc SaveAndExit {expnam} {
423    global CIFselect
424    if {$CIFselect(changes) > 0} {
425        set ans [MyMessageBox -parent . -title "Save?" \
426                -message "You have made $CIFselect(changes) changes to publication flags. Do you want to save them and exit; quit without saving; or cancel the exit request?" \
427                -icon question -type {Save Quit Cancel} -default Save]
428        if {[string tolower $ans] == "cancel"} return
429        if {[string tolower $ans] == "save"} {SaveFlags $expnam}
430    }
431    destroy $CIFselect(seltop)
432    destroy $CIFselect(seldisplay)
433    wm deiconify .
434}
435
436# start the CIFselect procedure to select distances and angles
437proc CIFselect {expfile} {
438    # check if file exists
439    set expnam [file root $expfile]
440    if {![file exists ${expnam}.DISAGL]} {
441        MyMessageBox -parent . -title "No DISAGL file" \
442                -message "No distances/angles to select: file ${expnam}.DISAGL was not found. Have you run DISAGL?" \
443                -icon warning -type Quit -default Quit
444        return
445    }
446   
447    global expmap labelarr symlist disarr dislist angarr disflag angflag CIFselect
448    catch {
449        unset labelarr
450        unset symlist
451        unset disarr
452        unset dislist
453        unset angarr
454        unset disflag
455        unset angflag
456    }
457
458    foreach phase $expmap(phaselist) {
459        foreach atom $expmap(atomlist_$phase) {
460            set labelarr(${phase}P${atom}) [atominfo $phase $atom label]
461        }
462    }
463   
464    # open file & skip 1st line
465    set fp [open ${expnam}.DISAGL r]
466    gets $fp line
467    # process the rest
468    while {[gets $fp line] >= 0} {
469        set phase [lindex $line 1]
470        if {[lindex $line 2] == 0} {
471            # distance
472            set center [lindex $line 5]
473            set a1 [lindex $line 6]
474            set a1l ${phase}P$a1
475            set sym [lindex $line 7]_[lindex $line 8]
476            if {[catch {set symlist($a1l)}]} {set symlist($a1l) $sym}
477            if {[lsearch $symlist($a1l) $sym] == -1} {
478                lappend symlist($a1l) $sym
479            }
480            set i [lsearch $symlist($a1l) $sym]
481            incr i
482            set atom1 ${a1}_[codenumber $i]
483            lappend dislist(${phase}P${center}) $atom1
484            set disarr(${phase}P${center}:$atom1) [lrange $line 3 4]
485            if {[string tolower [lindex $line 0]] =="y"} {
486                set disflag(${phase}P${center}:$atom1) 1
487            } else {
488                set disflag(${phase}P${center}:$atom1) 0
489            }
490        } elseif {[lindex $line 2] == 1} {
491            # angle
492            set center [lindex $line 6]
493            set a1 [lindex $line 5]
494            set a1l ${phase}P$a1
495            set a2 [lindex $line 7]
496            set a2l ${phase}P$a2
497            set sym1 [lindex $line 8]_[lindex $line 9]
498            set sym2 [lindex $line 10]_[lindex $line 11]
499            foreach sym [list $sym1 $sym2] {
500                if {[catch {set symlist($a1l)}]} {set symlist($a1l) $sym}
501                if {[lsearch $symlist($a1l) $sym] == -1} {
502                    lappend symlist($a1l) $sym
503                }
504            }
505            set i [lsearch $symlist($a1l) $sym1]
506            incr i
507            set atom1 ${a1}_[codenumber $i]
508            set i [lsearch $symlist($a2l) $sym2]
509            incr i
510            set atom2 ${a2}_[codenumber $i]
511            set angarr(${phase}P${center}:${atom1}:${atom2}) [lrange $line 3 4]
512            if {[string tolower [lindex $line 0]] =="y"} {
513                set angflag(${phase}P${center}:${atom1}:${atom2}) 1
514            } else {
515                set angflag(${phase}P${center}:${atom1}:${atom2}) 0
516            }
517        }
518    }
519    close $fp
520    # no changes yet
521    set CIFselect(changes) 0
522
523    # create the GUI
524    set top .seldis
525    set CIFselect(seltop) $top
526    catch {destroy $top}
527    toplevel $top
528    wm title $top "Selection modes"
529    bind $top <Key-F1> "MakeWWWHelp gsas2cif.html cifselect"
530
531    grid [frame $top.mode -bd 4 -relief groove] -row 1 -col 1 -sticky news
532    grid [label $top.mode.l -text "Response to Mouse click:"] \
533            -row 1 -col 0 -columnspan 99 
534    set col 1
535    foreach val {Toggle Set Clear} {
536        grid [radiobutton $top.mode.r$col -text $val \
537                -variable CIFselect(click) \
538                -value [string tolower $val]] -row 2 -col $col
539        incr col
540    }
541   
542    grid [frame $top.sel -bd 4 -relief groove] -row 2 -col 1 -sticky news
543    grid [label $top.sel.l -text "Distance selection: select matching angles?"] \
544            -row 1 -col 1 -columnspan 3
545    set col 1
546    foreach val {Yes No} {
547        grid [radiobutton $top.sel.r$col -text $val \
548                -variable CIFselect(select) \
549                -value [string tolower $val]] -row 2 -col $col
550        incr col
551    }
552   
553    grid [frame $top.ph -bd 4 -relief groove] -row 1 -col 0 -sticky news
554    grid [label $top.ph.h -text "Select phase"] -row 1 -col 0 -columnspan 99
555    set col 0
556    foreach phase $expmap(phaselist) {
557        grid [radiobutton $top.ph.r$col -text $phase \
558                -variable CIFselect(phase) \
559                -command SelectPhase \
560                -value $phase] -row 2 -col $col
561        incr col
562    }
563    grid columnconfigure $top 0 -weight 1
564    grid rowconfigure $top 3 -weight 1
565
566    grid [frame $top.atom -bd 4 -relief groove] \
567            -row 2 -rowspan 2 -col 0 -sticky news
568    grid [label $top.atom.h -text "Select atom"] -row 1 -col 0 -columnspan 99
569    set CIFselect(atomlist) $top.atom.lbox
570    grid columnconfigure $top.atom 0 -weight 1
571    grid rowconfigure $top.atom 2 -weight 1
572    grid [listbox $top.atom.lbox -height 4 -width 10 \
573            -exportselection 0 -yscrollcommand " $top.atom.rscr set"\
574            ] -row 2 -column 0 -sticky news
575    grid [scrollbar $top.atom.rscr  -command "$top.atom.lbox yview" \
576            ] -row 2 -column 1 -sticky ns
577    bind $top.atom.lbox <<ListboxSelect>> SelectAtom
578   
579    grid [frame $top.bt] -row 3 -col 1 -sticky news
580    button $top.bt.save -command "SaveFlags $expnam" -text Save
581    button $top.bt.export -command ExportDistAngMatrix -text "Export Tables"
582    button $top.bt.exit -command "SaveAndExit $expnam" -text Exit
583    grid $top.bt.save $top.bt.export $top.bt.exit -pad 5 -sticky s
584    grid columnconfig $top.bt 1 -weight 1
585    grid rowconfig $top.bt 0 -weight 1
586
587    set CIFselect(seldisplay) .selshow
588    catch {destroy $CIFselect(seldisplay)}
589    toplevel $CIFselect(seldisplay)
590    wm title $CIFselect(seldisplay) "Distance & Angle Table"
591    bind $CIFselect(seldisplay) <Key-F1> "MakeWWWHelp gsas2cif.html cifselect"
592    FillDistAngMatrix "" ""
593   
594    bind $CIFselect(seldisplay) <Configure> {
595        ConfigureCommand %W $CIFselect(seldisplay).a
596    }
597   
598    wm iconify .
599    # select the first phase
600    set CIFselect(phase) [lindex $expmap(phaselist) 0]
601    SelectPhase
602}
603
604set CIFselect(click) set
605set CIFselect(select) yes
606
Note: See TracBrowser for help on using the repository browser.