Changeset 643 for trunk/import_cif.tcl


Ignore:
Timestamp:
Dec 4, 2009 5:09:36 PM (11 years ago)
Author:
toby
Message:

# on 2002/09/05 18:17:58, toby did:
Major rework to use text-based browsecif.tcl

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/import_cif.tcl

    • Property rcs:date changed from 2002/07/03 21:01:45 to 2002/09/05 18:17:58
    • Property rcs:lines changed from +3 -1 to +44 -458
    • Property rcs:rev changed from 1.9 to 1.10
    r604 r643  
    33#-------------------------------------------------
    44# define info used in addcmds.tcl
    5 set description "Crystallographic Information File (CIF)"
    6 set extensions .cif
    7 set procname ReadCIFFile
     5catch {
     6    source [file join $expgui(scriptdir) browsecif.tcl]
     7    set description "Crystallographic Information File (CIF)"
     8    set extensions .cif
     9    set procname ReadCIFFile
     10}
    811#-------------------------------------------------
    912
    1013proc ReadCIFFile {filename} {
    11     global expgui
     14    global expgui CIF
    1215    set fp [open $filename r]
    1316    pleasewait "Reading CIF file"         
    14     set blocks [ParseCIF $filename]
     17
     18    catch {destroy [set file .file]}
     19    toplevel $file
     20    #bind $file <Key-F1> "MakeWWWHelp gsas2cif.html filltemplate"
     21    set CIF(txt) $file.t
     22    grid [text $CIF(txt) -height 10 -width 80 -yscrollcommand "$file.s set"] \
     23            -col 0 -row 0 -sticky news
     24    grid [scrollbar $file.s -command "$CIF(txt) yview"] \
     25            -col 1 -row 0 -sticky ns
     26    grid columnconfig $file 0 -weight 1
     27    grid rowconfig $file 0 -weight 1
     28    # hide it
     29    wm withdraw $file
     30    set blocks [ParseCIF $CIF(txt) $filename]
    1531    if {$blocks == ""} {
    1632        donewait
     
    4561        bind .choose <Key-F1> "MakeWWWHelp expguierr.html ChooseCIF"
    4662        grid [label .choose.0 -text \
    47                 "More than one block in CIF $filename\ncontains coordinates.\nSelect the block to use" \
     63                "More than one block in CIF $filename\ncontains coordinates.\n\nSelect the block to use" \
    4864                ] -row 0 -column 0 -columnspan 2
    4965        set row 0
     
    5773        }
    5874        grid [button .choose.browse -text CIF\nBrowser -command \
    59                 "BrowseCIF [list $allblocks] [list $coordblocks] .choose.cif" \
     75                "CallBrowseCIF $CIF(txt) [list $allblocks] [list $coordblocks] .choose.cif" \
    6076                ] -row 1 -rowspan $row -column 1
    6177        grid [button .choose.ok -text OK -command "destroy .choose"] \
     
    7692    set msg {}
    7793    catch {
    78         set spg [set block${i}(_symmetry_space_group_name_h-m)]
     94        set spg [ValueFromCIF block${i} _symmetry_space_group_name_h-m]
    7995        set sgtmp [string toupper $spg]
    8096        # remove spaces from space group
     
    123139        # leave blank any unspecified data items
    124140        set val {}
    125         catch {set val [set block${i}($var)]}
     141        catch {set val [ValueFromCIF block${i} $var]}
    126142        lappend cell [lindex [ParseSU $val] 0]
    127143    }
     
    130146    set lbllist {}
    131147    catch {
    132         set lbllist [set block${i}(_atom_site_label)]
     148        set lbllist [ValueFromCIF block${i} _atom_site_label]
    133149    }
    134150    set uisolist {}
    135151    set Uconv 1
    136152    catch {
    137         set uisolist [set block${i}(_atom_site_u_iso_or_equiv)]
     153        set uisolist [ValueFromCIF block${i} _atom_site_u_iso_or_equiv]
    138154    }
    139155    if {$uisolist == ""} {
    140156        catch {
    141             set uisolist [set block${i}(_atom_site_b_iso_or_equiv)]
     157            set uisolist [ValueFromCIF block${i} _atom_site_b_iso_or_equiv]
    142158            set Uconv [expr 1/(8*3.14159*3.14159)]
    143159        }
     
    145161    set occlist {}
    146162    catch {
    147         set occlist [set block${i}(_atom_site_occupancy)]
     163        set occlist [ValueFromCIF block${i} _atom_site_occupancy]
    148164    }
    149165    set typelist {}
    150166    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)] \
     167        set typelist [ValueFromCIF block${i} _atom_site_type_symbol]
     168    }
     169    foreach x [ValueFromCIF block${i} _atom_site_fract_x] \
     170            y [ValueFromCIF block${i} _atom_site_fract_y] \
     171            z [ValueFromCIF block${i} _atom_site_fract_z] \
    156172            lbl $lbllist uiso $uisolist occ $occlist type $typelist {
    157173        if {$uiso == ""} {set uiso 0.025}
     
    189205    }
    190206
    191     # clean up -- get rid of the CIF arrays
     207    # clean up -- get rid of the CIF arrays & window
    192208    for {set i 1} {$i <= $blocks} {incr i} {
    193209        unset block$i
    194210    }
     211    destroy $file
    195212    return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
    196213}
    197214
    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 #
    215 proc 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                 } else {
    347                     append item \n $line
    348                 }
    349             }
    350             if {[string trim $line] == ""} {set line ""}
    351         } elseif {$firstchar == {"}} {
    352             # a quoted string
    353             # hide any \" sequences in a non-ASCII character (\201)
    354             set hidden [regsub -all {\\"} $trimline \201 trimline]
    355             # parse out the quoted string, save the remainder
    356             if {![regexp {"([^"]*)"(.*)} $trimline junk item line]} {
    357                 # this is an error -- no end-quote was found
    358                 set item $line
    359                 set line {}
    360                 append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
    361             }
    362         } elseif {$firstchar == {'}} {
    363             # a quoted string
    364             # hide any \' sequences in a non-ASCII character (\200)
    365             set hidden [regsub -all {\\'} $trimline \200 trimline]
    366             # parse out the quoted string, save the remainder
    367             if {![regexp {'([^']*)'(.*)} $trimline junk item line]} {
    368                 # this is an error -- no end-quote was found
    369                 set item $line
    370                 set line {}
    371                 append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
    372             }
    373         } else {
    374             # must be a single space-delimited value
    375             set pos [string first { } $trimline]
    376             if {$pos < 0} {
    377                 # and the only thing left on the line
    378                 set item $trimline
    379                 set line {}
    380             } else {
    381                 # save the rest of the line
    382                 set line [string range $trimline $pos end]
    383                 incr pos -1
    384                 set item [string range $trimline 0 $pos]
    385             }
    386         }
    387        
    388         # a data item has been read
    389         # fix the hidden characters, if any
    390         if $hidden {
    391             regsub -all \200 $item {\\'} item
    392             regsub -all \201 $item {\\"} item
    393         }
    394 
    395         # store the data item
    396         if {$loopflag >= 0} {
    397             # if in a loop, increment the loop element counter to select the
    398             # appropriate array element
    399             incr loopflag
    400             set i [expr ($loopflag - 1) % [llength $looplist]]
    401             lappend block${blocks}([lindex $looplist $i]) $item
    402         } elseif {$dataname == ""} {
    403             # this is an error -- a data item where we do not expect one
    404             append block${blocks}(errors) "The string \"$item\" on line $linenum was unexpected\n"
    405         } else {
    406             catch {
    407                 if {[set block${blocks}($dataname)] != ""} {
    408                     # this is an error -- repeated data name
    409                     append block${blocks}(errors) \
    410                             "Data item $dataname is repeated near line $linenum\n"
    411                 }
    412             }
    413             set block${blocks}($dataname) $item
    414             set dataname ""
    415         }
    416     }
    417     close $fp
    418     return $blocks
     215
     216proc CallBrowseCIF {txt blocklist selected frame} {
     217    global CIF CIF_index CIF_dataname_index expgui
     218
     219    catch {
     220        source  [file join $expgui(scriptdir) CIF_index]
     221    }
     222
     223    # add location of these files & the typical GSAS data directory
     224    # to the dictionary search path
     225    lappend CIF(cif_path) $expgui(scriptdir) [file join [file dirname $expgui(scriptdir)] data]
     226   
     227    BrowseCIF $txt $blocklist $selected $frame
    419228}
    420 
    421 # this proc creates a hierarchical CIF browser
    422 # note that the BWidget package is required
    423 proc BrowseCIF {blocklist "selected {}" "frame .cif"} {
    424 
    425     if [catch {package require BWidget}] {
    426         tk_dialog $frame {No BWidget} \
    427                 "Sorry, the CIF Browser requires the BWidget package" \
    428                 warning 0 Continue
    429         return
    430     }
    431     if {$selected == ""} {set selected $blocklist}
    432     catch {destroy $frame}
    433     toplevel $frame
    434     wm title $frame "CIF Browser"
    435 
    436     set pw    [PanedWindow $frame.pw -side top]
    437     grid $pw -sticky news -column 0 -row 0
    438     grid columnconfigure $frame 0 -weight 1
    439     grid rowconfigure $frame 0 -minsize 250 -weight 1
    440 
    441     # create a left hand side pane for the hierarchical tree
    442     set pane  [$pw add -weight 1]
    443     set sw    [ScrolledWindow $pane.lf \
    444             -relief sunken -borderwidth 2]
    445     set tree  [Tree $sw.tree \
    446             -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
    447             -redraw 1]
    448     grid $sw
    449     grid $sw -sticky news -column 0 -row 0
    450     grid columnconfigure $pane 0 -minsize 275 -weight 1
    451     grid rowconfigure $pane 0 -weight 1
    452     $sw setwidget $tree
    453    
    454     # create a right hand side pane to show the value
    455     set pane [$pw add -weight 1]
    456     set sw   [ScrolledWindow $pane.sw \
    457             -relief sunken -borderwidth 2]
    458     pack $sw -fill both -expand yes -side bottom
    459     set lb [ScrollableFrame::create $sw.lb -width 250]
    460     $sw setwidget $lb
    461 
    462     set num 0
    463     foreach n $blocklist {
    464         global block$n
    465         # make a list of data names in loops
    466         set looplist {}
    467         foreach loop [array names block$n loop_*] {
    468             eval lappend looplist [set block${n}($loop)]
    469         }
    470         # put the block name
    471         set blockname [set block${n}(data_)]
    472         set open 0
    473         if {[lsearch $selected $n] != -1} {set open 1}
    474         $tree insert end root block$n -text "_data_$blockname" \
    475                 -open $open -image [Bitmap::get copy]
    476         # loop over the names in each block
    477         foreach name [array names block$n _*] {
    478             # don't include looped names
    479             if {[lsearch $looplist $name] == -1} {
    480                 $tree insert end block$n [incr num] -text $name \
    481                         -image [Bitmap::get folder] -data block$n
    482             }
    483         }
    484         foreach loop [array names block$n loop_*] {
    485             $tree insert end block$n block${n}$loop -text $loop \
    486                     -image [Bitmap::get file] -data "block$n loop"
    487             foreach name [set block${n}($loop)] {
    488                 $tree insert end block${n}$loop [incr num] -text $name \
    489                         -image [Bitmap::get folder] -data "block$n $loop"
    490             }
    491         }
    492         foreach name [array names block$n errors] {
    493             $tree insert end block$n [incr num] -text $name \
    494                     -image [Bitmap::get undo] -data block$n
    495         }
    496     }
    497     $tree bindImage <1> "showCIFvalue $tree $sw"
    498     $tree bindText <1> "showCIFvalue $tree $sw"
    499     grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
    500 }
    501 
    502 # used in BrowseCIF in response to the spinbox
    503 # show the contents of a loop
    504 proc ShowLoopVar {array loop frame sb} {
    505     global $array
    506     set looplist [set ${array}($loop)]
    507     set index [$sb getvalue]
    508     set i 0
    509     foreach var $looplist {
    510         incr i
    511         [$frame.$i getframe].l config \
    512                 -text [lindex [set ${array}($var)] $index]
    513     }
    514 }
    515 
    516 # used in BrowseCIF in response to the clicking on a CIF dataname
    517 # shows the contents data name or a loop
    518 proc showCIFvalue {tree sw name} {
    519     set data [$tree itemcget $name -data]
    520     set text [$tree itemcget $name -text]
    521 
    522     # delete old contents of frame
    523     set frame [$sw.lb getframe]
    524     eval destroy [grid slaves $frame]
    525     # reset the scrollbars
    526     $sw.lb xview moveto 0
    527     $sw.lb yview moveto 0
    528     # leave room for a scrollbar
    529     grid columnconfig $frame 0 -minsize [expr \
    530             [winfo width [winfo parent $frame]] - 20]
    531     if {$data == ""} {
    532         return
    533     }
    534    
    535     #
    536     if {[llength $data] == 2} {
    537         global [lindex $data 0]
    538         if {[lindex $data 1] == "loop"} {
    539             set looplist [set [lindex $data 0]($text)]
    540             # get number of elements for first name
    541             set names [llength [set [lindex $data 0]([lindex $looplist 0])]]
    542             set sb $frame.spin
    543             grid [SpinBox $sb -range "1 $names 1" \
    544                     -label "Loop\nelement #" -labelwidth 10 -width 10 \
    545                     -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
    546                     -modifycmd  "ShowLoopVar [lindex $data 0] $text $frame $sb"] \
    547                     -column 0 -row 0 -sticky w
    548             set i 0
    549             foreach var $looplist {
    550                 incr i
    551                 grid [TitleFrame $frame.$i -text $var -side left] \
    552                         -column 0 -row $i -sticky ew
    553                 pack [label [$frame.$i getframe].l -anchor w -justify left] -side left
    554             }
    555             ShowLoopVar [lindex $data 0] $text $frame $sb
    556         } else {
    557             grid [TitleFrame $frame.0 -text $text -side left] \
    558                     -column 0 -row 0 -sticky ew
    559             set row 0
    560             set frame0 [$frame.0 getframe]
    561             grid columnconfig $frame0 2 -weight 1
    562             foreach name [set [lindex $data 0]($text)] {
    563                 incr row
    564                 grid [label $frame0.a$row -justify left -text $row]\
    565                         -sticky w -column 0 -row $row
    566                 grid [label $frame0.b$row -bd 2 -relief groove \
    567                         -justify left -anchor w -text $name]\
    568                         -sticky new -column 1 -row $row
    569             }
    570         }
    571     } else {
    572         # unlooped data name
    573         global [lindex $data 0]
    574         grid [TitleFrame $frame.0 -text $text -side left] \
    575                 -column 0 -row 0 -sticky ew
    576         pack [label [$frame.0 getframe].l -anchor w -justify left\
    577                 -text [set ${data}($text)]] -side left
    578     }
    579 }
    580 
    581 # Parse a number in CIF, that may include a SU (ESD) value
    582 # note that this routine will ignore spaces, quotes & semicolons
    583 proc ParseSU {value} {
    584     # if there is no SU just return the value
    585     if {[string first "(" $value] == -1} {
    586         return $value
    587     }
    588     # is there a decimal point?
    589     if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
    590         set ex [string length $b]
    591         return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
    592     }
    593     if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
    594         return [list ${a} $err]
    595     }
    596     tk_dialog .err {ParseSU Error} \
    597             "ParseSU: Error processing value $value" \
    598             warning 0 Continue
    599 }
    600 
    601 # a stand-alone routine for testing. Select, read and browse a CIF
    602 proc Read_BrowseCIF {} {
    603     global tcl_platform
    604     if {$tcl_platform(platform) == "windows"} {
    605         set filetypelist {
    606             {"CIF files" .CIF} {"All files" *}
    607         }
    608     } else {
    609         set filetypelist {
    610             {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
    611         }
    612     }   
    613     set file [tk_getOpenFile -parent . -filetypes $filetypelist]
    614     if {$file == ""} return
    615     if {![file exists $file]} return
    616     # plasewait and donewait are defined in gsascmds.tcl and may not be present
    617     catch {pleasewait "Reading CIF file"}
    618     set blocks [ParseCIF $file]
    619     if {$blocks == ""} {
    620         donewait
    621         MessageBox -parent . -type ok -icon warning \
    622                 -message "Note: no valid CIF blocks were read from file $filename"
    623         return
    624     }
    625     catch {donewait}
    626     set allblocks {}
    627     for {set i 1} {$i <= $blocks} {incr i} {
    628         lappend allblocks $i
    629     }
    630     if {$allblocks != ""} {
    631         BrowseCIF $allblocks "" .cif
    632         # wait for the window to close
    633         tkwait window .cif
    634     } else {
    635         puts "no blocks read"
    636     }
    637     # clean up -- get rid of the CIF arrays
    638     for {set i 1} {$i <= $blocks} {incr i} {
    639         global block$i
    640         unset block$i
    641     }
    642 }
Note: See TracChangeset for help on using the changeset viewer.