source: trunk/cifselect.tcl @ 1253

Last change on this file since 1253 was 1251, checked in by toby, 7 years ago

use svn ps svn:eol-style "native" * to change line ends

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