source: trunk/import_cif.tcl @ 561

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

# on 2002/02/11 17:33:41, toby did:
Change quote processing of CIF's -- strip quotes as items are read (keep semicolons)
fix bug in spacegroup validation

  • Property rcs:author set to toby
  • Property rcs:date set to 2002/02/11 17:33:41
  • Property rcs:lines set to +4 -5
  • Property rcs:rev set to 1.8
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 19.7 KB
Line 
1# $Id: import_cif.tcl 561 2009-12-04 23:08:14Z toby $
2
3#-------------------------------------------------
4# define info used in addcmds.tcl
5set description "Crystallographic Information File (CIF)"
6set extensions .cif
7set procname ReadCIFFile
8#-------------------------------------------------
9
10proc ReadCIFFile {filename} {
11    global expgui
12    set fp [open $filename r]
13    pleasewait "Reading CIF file"         
14    set blocks [ParseCIF $filename]
15    if {$blocks == ""} {
16        donewait
17        MyMessageBox -parent . -type ok -icon warning \
18                -message "Note: no valid CIF blocks were read from file $filename"
19        return 
20    }
21    set allblocks {}
22    set coordblocks {}
23    # search each block for coordinate
24    for {set i 1} {$i <= $blocks} {incr i} {
25        lappend allblocks $i
26        global block$i
27        set flag 1
28        foreach id {_atom_site_fract_x _atom_site_fract_y _atom_site_fract_z} {
29            if {[array name block$i $id] == ""} {set flag 0}
30        }
31        if $flag {lappend coordblocks $i}
32    }
33    donewait
34    if {$coordblocks == ""} {
35        MyMessageBox -parent . -type ok -icon warning \
36                -message "Note: CIF $filename contains no coordinates"
37        return
38    }
39    set expgui(choose) [lindex $coordblocks 0]
40    # there is more than one appropriate block
41    if {[llength $coordblocks] > 1} {
42        catch {destroy .choose}
43        toplevel .choose
44        wm title .choose "Choose CIF Block"
45        bind .choose <Key-F1> "MakeWWWHelp expguierr.html ChooseCIF"
46        grid [label .choose.0 -text \
47                "More than one block in CIF $filename\ncontains coordinates.\nSelect the block to use" \
48                ] -row 0 -column 0 -columnspan 2
49        set row 0
50        foreach i $coordblocks {
51            incr row
52            set name ""
53            catch {set name [set block${i}(data_)]}
54            grid [radiobutton .choose.$row -value $i \
55                    -text "block $i ($name)" -variable expgui(choose)] \
56                    -row $row -column 0 -sticky w
57        }
58        grid [button .choose.browse -text CIF\nBrowser -command \
59                "BrowseCIF [list $allblocks] [list $coordblocks] .choose.cif" \
60                ] -row 1 -rowspan $row -column 1 
61        grid [button .choose.ok -text OK -command "destroy .choose"] \
62                -row [incr row] -column 0 -sticky w
63        grid [button .choose.help -text Help -bg yellow \
64            -command "MakeWWWHelp expguierr.html ChooseCIF"] \
65            -column 1 -row $row -sticky e
66        putontop .choose
67        tkwait window .choose
68        # fix grab...
69        afterputontop
70    }
71
72    set i $expgui(choose)
73    # get the space group
74    set spg {}
75    set sgnum {}
76    set msg {}
77    catch {
78        set spg [set block${i}(_symmetry_space_group_name_h-m)]
79        set sgtmp [string toupper $spg]
80        # remove spaces from space group
81        regsub -all " " $sgtmp "" sgtmp
82        # make a copy where we treat bar 3 as the same as 3
83        regsub -- "-3" $sgtmp "3" sgtmp3
84        # see if this space group exists in the table
85        set fp1 [open [file join \
86                $expgui(scriptdir) spacegrp.ref] r]
87        while {[gets $fp1 line] >= 0} {
88            set testsg [string toupper [lindex $line 8]]
89            regsub -all " " $testsg "" testsg
90            if {$testsg == $sgtmp} {
91                set spg [lindex $line 8]
92                set sgnum [lindex $line 1]
93                break
94            } elseif {[lindex $line 1] >= 200} {
95                regsub -- "-3" $testsg "3" testsg3
96                if {$testsg3 == $sgtmp3} {
97                    set spg [lindex $line 8]
98                    set sgnum [lindex $line 1]
99                    break
100                }
101            } elseif {[lindex $line 1] <= 18} {
102                # monoclinic: change operators of form "1 xxx 1" to "xxx"
103                regsub -- " 1 (.*) 1" [string toupper [lindex $line 8]] "\\1" testsg
104                # remove spaces from space group
105                regsub -all " " $testsg "" testsg
106                if {$testsg == $sgtmp} {
107                    set spg [lindex $line 8]
108                    set sgnum [lindex $line 1]
109                    break
110                }
111            }
112        }
113        close $fp1
114        if {$spg == ""} {
115            set msg "Warning: a Space Group must be specified"
116        } elseif {$sgnum == ""} {
117            set msg "Warning: the Space Group ($spg) is likely incorrect for GSAS"
118        }
119    }
120    set cell {}
121    foreach var {_cell_length_a _cell_length_b _cell_length_c \
122            _cell_angle_alpha _cell_angle_beta _cell_angle_gamma} {
123        # leave blank any unspecified data items
124        set val {}
125        catch {set val [set block${i}($var)]}
126        lappend cell [lindex [ParseSU $val] 0]
127    }
128   
129    set atomlist {}
130    set lbllist {}
131    catch {
132        set lbllist [set block${i}(_atom_site_label)]
133    }
134    set uisolist {}
135    set Uconv 1
136    catch {
137        set uisolist [set block${i}(_atom_site_u_iso_or_equiv)]
138    }
139    if {$uisolist == ""} {
140        catch {
141            set uisolist [set block${i}(_atom_site_b_iso_or_equiv)]
142            set Uconv [expr 1/(8*3.14159*3.14159)]
143        }
144    }
145    set occlist {}
146    catch {
147        set occlist [set block${i}(_atom_site_occupancy)]
148    }
149    set typelist {}
150    catch {
151        set typelist [set block${i}(_atom_site_type_symbol)]
152    }
153    foreach x [set block${i}(_atom_site_fract_x)] \
154            y [set block${i}(_atom_site_fract_y)] \
155            z [set block${i}(_atom_site_fract_z)] \
156            lbl $lbllist uiso $uisolist occ $occlist type $typelist {
157        if {$uiso == ""} {set uiso 0.025}
158        # should not be any quotes, but remove them, if there are
159        foreach var {lbl type} {
160            foreach char {' \"} {
161                set q {\\}
162                append q $char
163                set hidden [regsub -all $q [set $var] \200 $var]
164                if {[string index [set $var] 0] == $char} {
165                    regsub -all $char [set $var] {} $var
166                }
167                if {$hidden} {regsub -all \200 [set $var] $char $var}
168            }
169        }
170        # CIF specifies types as Cu2+; GSAS uses Cu+2
171        if {[regexp {([A-Za-z]+)([1-9])([+-])} $type junk elem sign val]} {
172            set type ${elem}${val}$sign
173        }
174        # if type is missing, attempt to parse an element in the label
175        if {$type == "" && $lbl != ""} {
176            regexp {[A-Za-z][A-Za-z]?} $lbl type
177        }
178        # get rid of standard uncertainies
179        foreach var {x y z occ uiso} {
180            catch {
181                set $var [lindex [ParseSU [set $var]] 0]
182            }
183        }
184        # convert Biso to Uiso (if needed)
185        if {$Uconv != 1} {
186            catch {set $uiso [expr $Uconv*$uiso]}
187        }
188        lappend atomlist [list $lbl $x $y $z $type $occ $uiso]
189    }
190
191    # clean up -- get rid of the CIF arrays
192    for {set i 1} {$i <= $blocks} {incr i} {
193        unset block$i
194    }
195    return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
196}
197
198# ParseCIF reads and parses a CIF file putting the contents of
199# each block into arrays block1, block2,... in the caller's level
200#    the name of the block is saved as blockN(data_)
201# data names and items are saved as blockN(_data_name) = {data item}
202#    data items are not reformatted, thus quotes, semicolons & newlines
203#    are included in the data item string
204#    CIF names are converted to lower case
205# for looped data names, the data items are included in a list:
206#    blockN(_cif_name) = {item1 "item2 with spaces" item3 ...}
207# the contents of each loop are saved as blockN(loop_M)
208#
209# The proc returns the number of blocks that have been read or a
210#    null string if the file cannot be opened
211#
212# This parser does some error checking [errors are reported in blockN(error)]
213#    but the parser could get confused if the CIF has invalid syntax
214#
215proc ParseCIF {filename} {
216    if [catch {
217        set fp [open $filename r]
218    }] {return ""}
219
220    set blocks 0
221    set EOF 1
222    set line {}
223    set dataname {}
224    # line counter (for error messages)
225    set linenum 0
226    # this flags where we are w/r a loop_
227    #    -1 not in a loop
228    #     0 reading a loop header (data names)
229    #     1 reading the data items in a loop
230    set loopflag -1
231    set loopnum -1
232    # loop over tokens
233    while {$EOF} {
234        # read the next line, unless we have a holdover from the previous
235        if {[string length [string trim $line]] <= 0} {
236            incr linenum
237            if {[gets $fp line] < 0} {set EOF 0}
238        }
239        # flag if the string \' has been replaced
240        set hidden 0
241        set trimline [string trim $line]
242        set firstchar [string index $trimline 0]
243       
244        if {[string length $trimline] <= 0} {
245            # the line is blank
246            set line {}
247            continue
248        }
249       
250        if {$firstchar == "#"} {
251            # this is a comment
252            set line {}
253            continue
254        }
255       
256        if {[string tolower [string range $trimline 0 4]] == "data_"} {
257            # this is the beginning of a data block
258            incr blocks
259            # are there other tokens on this line?
260            if {[set pos [string first { } $trimline]] == -1} {
261                set blockname [string range $trimline 5 end]
262                set line {}
263            } else {
264                set blockname [string range $trimline 5 [expr $pos-1]]
265                set line [string range $trimline $pos end]
266            }
267            global block$blocks
268            catch {unset block$blocks}
269            set block${blocks}(data_) $blockname
270            set loopnum -1
271           
272            if {$line == ""} continue
273            if {$dataname != ""} {
274                # this is an error -- data_ block where a data item is expected
275                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
276                set dataname {}
277            }
278        }
279       
280        if {$firstchar == "_"} {
281            # this is a cif data name
282            if {$dataname != ""} {
283                # this is an error -- data name where a data item is expected
284                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
285            }
286            # parse it out & convert it to lower case
287            if {[set pos [string first { } $trimline]] == -1} {
288                # nothing else is on this line
289                set dataname [string tolower $trimline]
290                set line {}
291            } else {
292                # There other tokens on this line
293                set dataname [string tolower [string range $trimline 0 [expr $pos-1]]]
294                set line [string tolower [string range $trimline $pos end]]
295            }
296           
297            if {$loopflag == 0} {
298                # in a loop header, save the names in the loop list
299                lappend looplist $dataname
300                set block${blocks}(loop_${loopnum}) $looplist
301                # clear the array element for the data item
302                # -- should not be needed for a valid CIF but if a name is used
303                # -- twice in the same block, want to wipe out the 1st data
304                catch {
305                    if {[set block${blocks}($dataname)] != ""} {
306                        # this is an error -- repeated data name
307                        append block${blocks}(errors) \
308                                "Data item $dataname is repeated near line $linenum\n"
309                    }   
310                    set block${blocks}($dataname) {}
311                }
312                set dataname {}
313            } elseif {$loopflag > 0} {
314                # in a loop body, so the loop is over
315                set loopflag -1
316            }
317            continue
318        }
319       
320        if {[string tolower [string range $trimline 0 4]] == "loop_"} {
321            set loopflag 0
322            incr loopnum
323            set looplist {}
324            set block${blocks}(loop_${loopnum}) {}
325            # save any other tokens on this line
326            set line [string range $trimline 5 end]
327            continue
328        }
329
330        # keywords not matched, must be some type of data item
331        set item {}
332       
333        if {[string index $line 0] == ";"} {
334            # multiline entry with semicolon termination
335            set item $line
336            # read lines until we get a naked semicolon
337            while {$EOF} {
338                incr linenum
339                if {[gets $fp line] < 0} {set EOF 0}
340                if {[string index $line 0] == ";"} {
341                    append item "\n;"
342                    # make sure the line has a blank in front, so
343                    # a semicolon in col 2 is not treated as a quote character
344                    set line " [string range $line 1 end]"
345                    break
346                }
347            }
348            if {[string trim $line] == ""} {set line ""}
349        } elseif {$firstchar == {"}} {
350            # a quoted string
351            # hide any \" sequences in a non-ASCII character (\201)
352            set hidden [regsub -all {\\"} $trimline \201 trimline]
353            # parse out the quoted string, save the remainder
354            if {![regexp {"([^"]*)"(.*)} $trimline junk item line]} {
355                # this is an error -- no end-quote was found
356                set item $line
357                set line {}
358                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
359            }
360        } elseif {$firstchar == {'}} {
361            # a quoted string
362            # hide any \' sequences in a non-ASCII character (\200)
363            set hidden [regsub -all {\\'} $trimline \200 trimline]
364            # parse out the quoted string, save the remainder
365            if {![regexp {'([^']*)'(.*)} $trimline junk item line]} {
366                # this is an error -- no end-quote was found
367                set item $line
368                set line {}
369                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
370            }
371        } else {
372            # must be a single space-delimited value
373            set pos [string first { } $trimline]
374            if {$pos < 0} {
375                # and the only thing left on the line
376                set item $trimline
377                set line {}
378            } else {
379                # save the rest of the line
380                set line [string range $trimline $pos end]
381                incr pos -1
382                set item [string range $trimline 0 $pos]
383            }
384        }
385       
386        # a data item has been read
387        # fix the hidden characters, if any
388        if $hidden {
389            regsub -all \200 $item {\\'} item
390            regsub -all \201 $item {\\"} item
391        }
392
393        # store the data item
394        if {$loopflag >= 0} {
395            # if in a loop, increment the loop element counter to select the
396            # appropriate array element
397            incr loopflag
398            set i [expr ($loopflag - 1) % [llength $looplist]]
399            lappend block${blocks}([lindex $looplist $i]) $item
400        } elseif {$dataname == ""} {
401            # this is an error -- a data item where we do not expect one
402            append block${blocks}(errors) "The string \"$item\" on line $linenum was unexpected\n"
403        } else {
404            catch {
405                if {[set block${blocks}($dataname)] != ""} {
406                    # this is an error -- repeated data name
407                    append block${blocks}(errors) \
408                            "Data item $dataname is repeated near line $linenum\n"
409                }
410            }
411            set block${blocks}($dataname) $item
412            set dataname ""
413        }
414    }
415    close $fp
416    return $blocks
417}
418
419# this proc creates a hierarchical CIF browser
420# note that the BWidget package is required
421proc BrowseCIF {blocklist "selected {}" "frame .cif"} {
422
423    if [catch {package require BWidget}] {
424        tk_dialog $frame {No BWidget} \
425                "Sorry, the CIF Browser requires the BWidget package" \
426                warning 0 Continue
427        return
428    }
429    if {$selected == ""} {set selected $blocklist}
430    catch {destroy $frame}
431    toplevel $frame 
432    wm title $frame "CIF Browser"
433
434    set pw    [PanedWindow $frame.pw -side top]
435    grid $pw -sticky news -column 0 -row 0 
436    grid columnconfigure $frame 0 -weight 1
437    grid rowconfigure $frame 0 -minsize 250 -weight 1
438
439    # create a left hand side pane for the hierarchical tree
440    set pane  [$pw add -weight 1]
441    set sw    [ScrolledWindow $pane.lf \
442            -relief sunken -borderwidth 2]
443    set tree  [Tree $sw.tree \
444            -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
445            -redraw 1]
446    grid $sw
447    grid $sw -sticky news -column 0 -row 0 
448    grid columnconfigure $pane 0 -minsize 275 -weight 1
449    grid rowconfigure $pane 0 -weight 1
450    $sw setwidget $tree
451   
452    # create a right hand side pane to show the value
453    set pane [$pw add -weight 1]
454    set sw   [ScrolledWindow $pane.sw \
455            -relief sunken -borderwidth 2]
456    pack $sw -fill both -expand yes -side bottom
457    set lb [ScrollableFrame::create $sw.lb -width 250]
458    $sw setwidget $lb
459
460    set num 0
461    foreach n $blocklist {
462        global block$n
463        # make a list of data names in loops
464        set looplist {}
465        foreach loop [array names block$n loop_*] {
466            eval lappend looplist [set block${n}($loop)]
467        }
468        # put the block name
469        set blockname [set block${n}(data_)]
470        set open 0
471        if {[lsearch $selected $n] != -1} {set open 1}
472        $tree insert end root block$n -text "_data_$blockname" \
473                -open $open -image [Bitmap::get copy]
474        # loop over the names in each block
475        foreach name [array names block$n _*] {
476            # don't include looped names
477            if {[lsearch $looplist $name] == -1} {
478                $tree insert end block$n [incr num] -text $name \
479                        -image [Bitmap::get folder] -data block$n
480            }
481        }
482        foreach loop [array names block$n loop_*] {
483            $tree insert end block$n block${n}$loop -text $loop \
484                    -image [Bitmap::get file] -data "block$n loop"
485            foreach name [set block${n}($loop)] {
486                $tree insert end block${n}$loop [incr num] -text $name \
487                        -image [Bitmap::get folder] -data "block$n $loop"
488            }
489        }
490        foreach name [array names block$n errors] {
491            $tree insert end block$n [incr num] -text $name \
492                    -image [Bitmap::get undo] -data block$n
493        }
494    }
495    $tree bindImage <1> "showCIFvalue $tree $sw"
496    $tree bindText <1> "showCIFvalue $tree $sw"
497    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
498}
499
500# used in BrowseCIF in response to the spinbox
501# show the contents of a loop
502proc ShowLoopVar {array loop frame sb} {
503    global $array
504    set looplist [set ${array}($loop)]
505    set index [$sb getvalue]
506    set i 0
507    foreach var $looplist {
508        incr i
509        [$frame.$i getframe].l config \
510                -text [lindex [set ${array}($var)] $index]
511    }
512}
513
514# used in BrowseCIF in response to the clicking on a CIF dataname
515# shows the contents data name or a loop
516proc showCIFvalue {tree sw name} {
517    set data [$tree itemcget $name -data]
518    set text [$tree itemcget $name -text]
519
520    # delete old contents of frame
521    set frame [$sw.lb getframe]
522    eval destroy [grid slaves $frame]
523    # reset the scrollbars
524    $sw.lb xview moveto 0
525    $sw.lb yview moveto 0
526    # leave room for a scrollbar
527    grid columnconfig $frame 0 -minsize [expr \
528            [winfo width [winfo parent $frame]] - 20]
529    if {$data == ""} {
530        return
531    }
532   
533    #
534    if {[llength $data] == 2} {
535        global [lindex $data 0]
536        if {[lindex $data 1] == "loop"} {
537            set looplist [set [lindex $data 0]($text)]
538            # get number of elements for first name
539            set names [llength [set [lindex $data 0]([lindex $looplist 0])]]
540            set sb $frame.spin
541            grid [SpinBox $sb -range "1 $names 1" \
542                    -label "Loop\nelement #" -labelwidth 10 -width 10 \
543                    -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
544                    -modifycmd  "ShowLoopVar [lindex $data 0] $text $frame $sb"] \
545                    -column 0 -row 0 -sticky w
546            set i 0
547            foreach var $looplist {
548                incr i
549                grid [TitleFrame $frame.$i -text $var -side left] \
550                        -column 0 -row $i -sticky ew
551                pack [label [$frame.$i getframe].l -anchor w -justify left] -side left
552            }
553            ShowLoopVar [lindex $data 0] $text $frame $sb
554        } else {
555            grid [TitleFrame $frame.0 -text $text -side left] \
556                    -column 0 -row 0 -sticky ew
557            set row 0
558            set frame0 [$frame.0 getframe]
559            grid columnconfig $frame0 2 -weight 1
560            foreach name [set [lindex $data 0]($text)] {
561                incr row
562                grid [label $frame0.a$row -justify left -text $row]\
563                        -sticky w -column 0 -row $row
564                grid [label $frame0.b$row -bd 2 -relief groove \
565                        -justify left -anchor w -text $name]\
566                        -sticky new -column 1 -row $row 
567            }
568        }
569    } else {
570        # unlooped data name
571        global [lindex $data 0]
572        grid [TitleFrame $frame.0 -text $text -side left] \
573                -column 0 -row 0 -sticky ew
574        pack [label [$frame.0 getframe].l -anchor w -justify left\
575                -text [set ${data}($text)]] -side left
576    }
577}
578
579# Parse a number in CIF, that may include a SU (ESD) value
580# note that this routine will ignore spaces, quotes & semicolons
581proc ParseSU {value} {
582    # if there is no SU just return the value
583    if {[string first "(" $value] == -1} {
584        return $value
585    }
586    # is there a decimal point?
587    if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
588        set ex [string length $b]
589        return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
590    }
591    if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
592        return [list ${a} $err]
593    }
594    tk_dialog .err {ParseSU Error} \
595            "ParseSU: Error processing value $value" \
596            warning 0 Continue
597}
598
599# a stand-alone routine for testing. Select, read and browse a CIF
600proc Read_BrowseCIF {} {
601    global tcl_platform
602    if {$tcl_platform(platform) == "windows"} {
603        set filetypelist {
604            {"CIF files" .CIF} {"All files" *}
605        }
606    } else {
607        set filetypelist {
608            {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
609        }
610    }   
611    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
612    if {$file == ""} return
613    if {![file exists $file]} return
614    # plasewait and donewait are defined in gsascmds.tcl and may not be present
615    catch {pleasewait "Reading CIF file"}
616    set blocks [ParseCIF $file]
617    if {$blocks == ""} {
618        donewait
619        MessageBox -parent . -type ok -icon warning \
620                -message "Note: no valid CIF blocks were read from file $filename"
621        return
622    }
623    catch {donewait}
624    set allblocks {}
625    for {set i 1} {$i <= $blocks} {incr i} {
626        lappend allblocks $i
627    }
628    if {$allblocks != ""} {
629        BrowseCIF $allblocks "" .cif
630        # wait for the window to close
631        tkwait window .cif
632    } else {
633        puts "no blocks read"
634    }
635    # clean up -- get rid of the CIF arrays
636    for {set i 1} {$i <= $blocks} {incr i} {
637        global block$i
638        unset block$i
639    }
640}
Note: See TracBrowser for help on using the repository browser.