Changeset 643

Timestamp:

Dec 4, 2009 5:09:36 PM (14 years ago)

Author:

toby

Message:

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

File:

• trunk/import_cif.tcl (modified) (8 diffs, 3 props)

trunk/import_cif.tcl

@@ -3 +3 @@
 #-------------------------------------------------
 # define info used in addcmds.tcl
-set description "Crystallographic Information File (CIF)"
-set extensions .cif
-set procname ReadCIFFile
+catch {
+    source [file join $expgui(scriptdir) browsecif.tcl]
+    set description "Crystallographic Information File (CIF)"
+    set extensions .cif
+    set procname ReadCIFFile
+}
 #-------------------------------------------------
 
 proc ReadCIFFile {filename} {
-    global expgui
+    global expgui CIF
     set fp [open $filename r]
     pleasewait "Reading CIF file"          
-    set blocks [ParseCIF $filename]
+
+    catch {destroy [set file .file]}
+    toplevel $file
+    #bind $file <Key-F1> "MakeWWWHelp gsas2cif.html filltemplate"
+    set CIF(txt) $file.t
+    grid [text $CIF(txt) -height 10 -width 80 -yscrollcommand "$file.s set"] \
+            -col 0 -row 0 -sticky news
+    grid [scrollbar $file.s -command "$CIF(txt) yview"] \
+            -col 1 -row 0 -sticky ns
+    grid columnconfig $file 0 -weight 1
+    grid rowconfig $file 0 -weight 1
+    # hide it
+    wm withdraw $file
+    set blocks [ParseCIF $CIF(txt) $filename]
     if {$blocks == ""} {
         donewait
@@ -45 +61 @@
         bind .choose <Key-F1> "MakeWWWHelp expguierr.html ChooseCIF"
         grid [label .choose.0 -text \
-                "More than one block in CIF $filename\ncontains coordinates.\nSelect the block to use" \
+                "More than one block in CIF $filename\ncontains coordinates.\n\nSelect the block to use" \
                 ] -row 0 -column 0 -columnspan 2
         set row 0
@@ -57 +73 @@
         }
         grid [button .choose.browse -text CIF\nBrowser -command \
-                "BrowseCIF [list $allblocks] [list $coordblocks] .choose.cif" \
+                "CallBrowseCIF $CIF(txt) [list $allblocks] [list $coordblocks] .choose.cif" \
                 ] -row 1 -rowspan $row -column 1 
         grid [button .choose.ok -text OK -command "destroy .choose"] \
@@ -76 +92 @@
     set msg {}
     catch {
-        set spg [set block${i}(_symmetry_space_group_name_h-m)]
+        set spg [ValueFromCIF block${i} _symmetry_space_group_name_h-m]
         set sgtmp [string toupper $spg]
         # remove spaces from space group
@@ -123 +139 @@
         # leave blank any unspecified data items
         set val {}
-        catch {set val [set block${i}($var)]}
+        catch {set val [ValueFromCIF block${i} $var]}
         lappend cell [lindex [ParseSU $val] 0]
     }
@@ -130 +146 @@
     set lbllist {}
     catch {
-        set lbllist [set block${i}(_atom_site_label)]
+        set lbllist [ValueFromCIF block${i} _atom_site_label]
     }
     set uisolist {}
     set Uconv 1
     catch {
-        set uisolist [set block${i}(_atom_site_u_iso_or_equiv)]
+        set uisolist [ValueFromCIF block${i} _atom_site_u_iso_or_equiv]
     }
     if {$uisolist == ""} {
         catch {
-            set uisolist [set block${i}(_atom_site_b_iso_or_equiv)]
+            set uisolist [ValueFromCIF block${i} _atom_site_b_iso_or_equiv]
             set Uconv [expr 1/(8*3.14159*3.14159)]
         }
@@ -145 +161 @@
     set occlist {}
     catch {
-        set occlist [set block${i}(_atom_site_occupancy)]
+        set occlist [ValueFromCIF block${i} _atom_site_occupancy]
     }
     set typelist {}
     catch {
-        set typelist [set block${i}(_atom_site_type_symbol)]
-    }
-    foreach x [set block${i}(_atom_site_fract_x)] \
-            y [set block${i}(_atom_site_fract_y)] \
-            z [set block${i}(_atom_site_fract_z)] \
+        set typelist [ValueFromCIF block${i} _atom_site_type_symbol]
+    }
+    foreach x [ValueFromCIF block${i} _atom_site_fract_x] \
+            y [ValueFromCIF block${i} _atom_site_fract_y] \
+            z [ValueFromCIF block${i} _atom_site_fract_z] \
             lbl $lbllist uiso $uisolist occ $occlist type $typelist {
         if {$uiso == ""} {set uiso 0.025}
@@ -189 +205 @@
     }
 
-    # clean up -- get rid of the CIF arrays
+    # clean up -- get rid of the CIF arrays & window
     for {set i 1} {$i <= $blocks} {incr i} {
         unset block$i
     }
+    destroy $file
     return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
 }
 
-# ParseCIF reads and parses a CIF file putting the contents of
-# each block into arrays block1, block2,... in the caller's level
-#    the name of the block is saved as blockN(data_)
-# data names and items are saved as blockN(_data_name) = {data item}
-#    data items are not reformatted, thus quotes, semicolons & newlines 
-#    are included in the data item string
-#    CIF names are converted to lower case
-# for looped data names, the data items are included in a list:
-#    blockN(_cif_name) = {item1 "item2 with spaces" item3 ...} 
-# the contents of each loop are saved as blockN(loop_M)
-#
-# The proc returns the number of blocks that have been read or a
-#    null string if the file cannot be opened
-#
-# This parser does some error checking [errors are reported in blockN(error)]
-#    but the parser could get confused if the CIF has invalid syntax
-#
-proc ParseCIF {filename} {
-    if [catch {
-        set fp [open $filename r]
-    }] {return ""}
-
-    set blocks 0
-    set EOF 1
-    set line {}
-    set dataname {}
-    # line counter (for error messages)
-    set linenum 0
-    # this flags where we are w/r a loop_
-    #    -1 not in a loop
-    #     0 reading a loop header (data names)
-    #     1 reading the data items in a loop
-    set loopflag -1
-    set loopnum -1
-    # loop over tokens
-    while {$EOF} {
-        # read the next line, unless we have a holdover from the previous
-        if {[string length [string trim $line]] <= 0} {
-            incr linenum
-            if {[gets $fp line] < 0} {set EOF 0}
-        }
-        # flag if the string \' has been replaced
-        set hidden 0
-        set trimline [string trim $line]
-        set firstchar [string index $trimline 0]
-        
-        if {[string length $trimline] <= 0} {
-            # the line is blank
-            set line {}
-            continue
-        } 
-        
-        if {$firstchar == "#"} {
-            # this is a comment
-            set line {}
-            continue
-        } 
-        
-        if {[string tolower [string range $trimline 0 4]] == "data_"} {
-            # this is the beginning of a data block
-            incr blocks
-            # are there other tokens on this line?
-            if {[set pos [string first { } $trimline]] == -1} {
-                set blockname [string range $trimline 5 end]
-                set line {}
-            } else {
-                set blockname [string range $trimline 5 [expr $pos-1]]
-                set line [string range $trimline $pos end]
-            }
-            global block$blocks
-            catch {unset block$blocks}
-            set block${blocks}(data_) $blockname
-            set loopnum -1
-            
-            if {$line == ""} continue
-            if {$dataname != ""} {
-                # this is an error -- data_ block where a data item is expected
-                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
-                set dataname {}
-            }
-        }
-        
-        if {$firstchar == "_"} {
-            # this is a cif data name
-            if {$dataname != ""} {
-                # this is an error -- data name where a data item is expected
-                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
-            }
-            # parse it out & convert it to lower case
-            if {[set pos [string first { } $trimline]] == -1} {
-                # nothing else is on this line
-                set dataname [string tolower $trimline]
-                set line {}
-            } else {
-                # There other tokens on this line
-                set dataname [string tolower [string range $trimline 0 [expr $pos-1]]]
-                set line [string tolower [string range $trimline $pos end]]
-            }
-            
-            if {$loopflag == 0} {
-                # in a loop header, save the names in the loop list
-                lappend looplist $dataname
-                set block${blocks}(loop_${loopnum}) $looplist
-                # clear the array element for the data item 
-                # -- should not be needed for a valid CIF but if a name is used
-                # -- twice in the same block, want to wipe out the 1st data
-                catch {
-                    if {[set block${blocks}($dataname)] != ""} {
-                        # this is an error -- repeated data name
-                        append block${blocks}(errors) \
-                                "Data item $dataname is repeated near line $linenum\n"
-                    }   
-                    set block${blocks}($dataname) {}
-                }
-                set dataname {}
-            } elseif {$loopflag > 0} {
-                # in a loop body, so the loop is over
-                set loopflag -1
-            }
-            continue
-        }
-        
-        if {[string tolower [string range $trimline 0 4]] == "loop_"} {
-            set loopflag 0
-            incr loopnum
-            set looplist {}
-            set block${blocks}(loop_${loopnum}) {}
-            # save any other tokens on this line
-            set line [string range $trimline 5 end]
-            continue
-        }
-
-        # keywords not matched, must be some type of data item
-        set item {}
-        
-        if {[string index $line 0] == ";"} {
-            # multiline entry with semicolon termination
-            set item $line
-            # read lines until we get a naked semicolon
-            while {$EOF} {
-                incr linenum
-                if {[gets $fp line] < 0} {set EOF 0}
-                if {[string index $line 0] == ";"} {
-                    append item "\n;"
-                    # make sure the line has a blank in front, so 
-                    # a semicolon in col 2 is not treated as a quote character
-                    set line " [string range $line 1 end]"
-                    break
-                } else {
-                    append item \n $line
-                }
-            }
-            if {[string trim $line] == ""} {set line ""}
-        } elseif {$firstchar == {"}} {
-            # a quoted string
-            # hide any \" sequences in a non-ASCII character (\201)
-            set hidden [regsub -all {\\"} $trimline \201 trimline]
-            # parse out the quoted string, save the remainder
-            if {![regexp {"([^"]*)"(.*)} $trimline junk item line]} {
-                # this is an error -- no end-quote was found
-                set item $line
-                set line {}
-                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
-            }
-        } elseif {$firstchar == {'}} {
-            # a quoted string
-            # hide any \' sequences in a non-ASCII character (\200)
-            set hidden [regsub -all {\\'} $trimline \200 trimline]
-            # parse out the quoted string, save the remainder
-            if {![regexp {'([^']*)'(.*)} $trimline junk item line]} {
-                # this is an error -- no end-quote was found
-                set item $line
-                set line {}
-                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
-            }
-        } else {
-            # must be a single space-delimited value
-            set pos [string first { } $trimline]
-            if {$pos < 0} {
-                # and the only thing left on the line
-                set item $trimline
-                set line {}
-            } else {
-                # save the rest of the line
-                set line [string range $trimline $pos end]
-                incr pos -1
-                set item [string range $trimline 0 $pos]
-            }
-        }
-        
-        # a data item has been read
-        # fix the hidden characters, if any
-        if $hidden {
-            regsub -all \200 $item {\\'} item
-            regsub -all \201 $item {\\"} item
-        }
-
-        # store the data item
-        if {$loopflag >= 0} {
-            # if in a loop, increment the loop element counter to select the
-            # appropriate array element
-            incr loopflag
-            set i [expr ($loopflag - 1) % [llength $looplist]]
-            lappend block${blocks}([lindex $looplist $i]) $item
-        } elseif {$dataname == ""} {
-            # this is an error -- a data item where we do not expect one
-            append block${blocks}(errors) "The string \"$item\" on line $linenum was unexpected\n"
-        } else {
-            catch {
-                if {[set block${blocks}($dataname)] != ""} {
-                    # this is an error -- repeated data name
-                    append block${blocks}(errors) \
-                            "Data item $dataname is repeated near line $linenum\n"
-                }
-            }
-            set block${blocks}($dataname) $item
-            set dataname ""
-        }
-    }
-    close $fp
-    return $blocks
+
+proc CallBrowseCIF {txt blocklist selected frame} {
+    global CIF CIF_index CIF_dataname_index expgui
+
+    catch {
+        source  [file join $expgui(scriptdir) CIF_index]
+    }
+
+    # add location of these files & the typical GSAS data directory 
+    # to the dictionary search path
+    lappend CIF(cif_path) $expgui(scriptdir) [file join [file dirname $expgui(scriptdir)] data]
+    
+    BrowseCIF $txt $blocklist $selected $frame
 }
-
-# this proc creates a hierarchical CIF browser 
-# note that the BWidget package is required
-proc BrowseCIF {blocklist "selected {}" "frame .cif"} {
-
-    if [catch {package require BWidget}] {
-        tk_dialog $frame {No BWidget} \
-                "Sorry, the CIF Browser requires the BWidget package" \
-                warning 0 Continue
-        return
-    }
-    if {$selected == ""} {set selected $blocklist}
-    catch {destroy $frame}
-    toplevel $frame 
-    wm title $frame "CIF Browser"
-
-    set pw    [PanedWindow $frame.pw -side top]
-    grid $pw -sticky news -column 0 -row 0 
-    grid columnconfigure $frame 0 -weight 1
-    grid rowconfigure $frame 0 -minsize 250 -weight 1
-
-    # create a left hand side pane for the hierarchical tree
-    set pane  [$pw add -weight 1]
-    set sw    [ScrolledWindow $pane.lf \
-            -relief sunken -borderwidth 2]
-    set tree  [Tree $sw.tree \
-            -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
-            -redraw 1]
-    grid $sw
-    grid $sw -sticky news -column 0 -row 0 
-    grid columnconfigure $pane 0 -minsize 275 -weight 1
-    grid rowconfigure $pane 0 -weight 1
-    $sw setwidget $tree
-    
-    # create a right hand side pane to show the value
-    set pane [$pw add -weight 1]
-    set sw   [ScrolledWindow $pane.sw \
-            -relief sunken -borderwidth 2]
-    pack $sw -fill both -expand yes -side bottom
-    set lb [ScrollableFrame::create $sw.lb -width 250]
-    $sw setwidget $lb
-
-    set num 0
-    foreach n $blocklist {
-        global block$n
-        # make a list of data names in loops
-        set looplist {}
-        foreach loop [array names block$n loop_*] {
-            eval lappend looplist [set block${n}($loop)]
-        }
-        # put the block name
-        set blockname [set block${n}(data_)]
-        set open 0
-        if {[lsearch $selected $n] != -1} {set open 1}
-        $tree insert end root block$n -text "_data_$blockname" \
-                -open $open -image [Bitmap::get copy]
-        # loop over the names in each block 
-        foreach name [array names block$n _*] {
-            # don't include looped names
-            if {[lsearch $looplist $name] == -1} {
-                $tree insert end block$n [incr num] -text $name \
-                        -image [Bitmap::get folder] -data block$n
-            }
-        }
-        foreach loop [array names block$n loop_*] {
-            $tree insert end block$n block${n}$loop -text $loop \
-                    -image [Bitmap::get file] -data "block$n loop"
-            foreach name [set block${n}($loop)] {
-                $tree insert end block${n}$loop [incr num] -text $name \
-                        -image [Bitmap::get folder] -data "block$n $loop"
-            }
-        }
-        foreach name [array names block$n errors] {
-            $tree insert end block$n [incr num] -text $name \
-                    -image [Bitmap::get undo] -data block$n
-        }
-    }
-    $tree bindImage <1> "showCIFvalue $tree $sw"
-    $tree bindText <1> "showCIFvalue $tree $sw"
-    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
-}
-
-# used in BrowseCIF in response to the spinbox
-# show the contents of a loop
-proc ShowLoopVar {array loop frame sb} {
-    global $array
-    set looplist [set ${array}($loop)]
-    set index [$sb getvalue]
-    set i 0
-    foreach var $looplist {
-        incr i
-        [$frame.$i getframe].l config \
-                -text [lindex [set ${array}($var)] $index]
-    }
-}
-
-# used in BrowseCIF in response to the clicking on a CIF dataname
-# shows the contents data name or a loop
-proc showCIFvalue {tree sw name} {
-    set data [$tree itemcget $name -data]
-    set text [$tree itemcget $name -text]
-
-    # delete old contents of frame
-    set frame [$sw.lb getframe]
-    eval destroy [grid slaves $frame]
-    # reset the scrollbars
-    $sw.lb xview moveto 0
-    $sw.lb yview moveto 0
-    # leave room for a scrollbar
-    grid columnconfig $frame 0 -minsize [expr \
-            [winfo width [winfo parent $frame]] - 20]
-    if {$data == ""} {
-        return
-    }
-    
-    #
-    if {[llength $data] == 2} {
-        global [lindex $data 0]
-        if {[lindex $data 1] == "loop"} {
-            set looplist [set [lindex $data 0]($text)]
-            # get number of elements for first name
-            set names [llength [set [lindex $data 0]([lindex $looplist 0])]]
-            set sb $frame.spin
-            grid [SpinBox $sb -range "1 $names 1" \
-                    -label "Loop\nelement #" -labelwidth 10 -width 10 \
-                    -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
-                    -modifycmd  "ShowLoopVar [lindex $data 0] $text $frame $sb"] \
-                    -column 0 -row 0 -sticky w
-            set i 0
-            foreach var $looplist {
-                incr i
-                grid [TitleFrame $frame.$i -text $var -side left] \
-                        -column 0 -row $i -sticky ew
-                pack [label [$frame.$i getframe].l -anchor w -justify left] -side left
-            }
-            ShowLoopVar [lindex $data 0] $text $frame $sb
-        } else {
-            grid [TitleFrame $frame.0 -text $text -side left] \
-                    -column 0 -row 0 -sticky ew
-            set row 0
-            set frame0 [$frame.0 getframe]
-            grid columnconfig $frame0 2 -weight 1
-            foreach name [set [lindex $data 0]($text)] {
-                incr row
-                grid [label $frame0.a$row -justify left -text $row]\
-                        -sticky w -column 0 -row $row
-                grid [label $frame0.b$row -bd 2 -relief groove \
-                        -justify left -anchor w -text $name]\
-                        -sticky new -column 1 -row $row 
-            }
-        }
-    } else {
-        # unlooped data name
-        global [lindex $data 0]
-        grid [TitleFrame $frame.0 -text $text -side left] \
-                -column 0 -row 0 -sticky ew
-        pack [label [$frame.0 getframe].l -anchor w -justify left\
-                -text [set ${data}($text)]] -side left
-    }
-}
-
-# Parse a number in CIF, that may include a SU (ESD) value
-# note that this routine will ignore spaces, quotes & semicolons
-proc ParseSU {value} {
-    # if there is no SU just return the value
-    if {[string first "(" $value] == -1} {
-        return $value
-    }
-    # is there a decimal point?
-    if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
-        set ex [string length $b]
-        return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
-    }
-    if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
-        return [list ${a} $err]
-    }
-    tk_dialog .err {ParseSU Error} \
-            "ParseSU: Error processing value $value" \
-            warning 0 Continue
-}
-
-# a stand-alone routine for testing. Select, read and browse a CIF
-proc Read_BrowseCIF {} {
-    global tcl_platform
-    if {$tcl_platform(platform) == "windows"} {
-        set filetypelist {
-            {"CIF files" .CIF} {"All files" *}
-        }
-    } else {
-        set filetypelist {
-            {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
-        }
-    }    
-    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
-    if {$file == ""} return
-    if {![file exists $file]} return
-    # plasewait and donewait are defined in gsascmds.tcl and may not be present
-    catch {pleasewait "Reading CIF file"}
-    set blocks [ParseCIF $file]
-    if {$blocks == ""} {
-        donewait
-        MessageBox -parent . -type ok -icon warning \
-                -message "Note: no valid CIF blocks were read from file $filename"
-        return
-    }
-    catch {donewait}
-    set allblocks {}
-    for {set i 1} {$i <= $blocks} {incr i} {
-        lappend allblocks $i
-    }
-    if {$allblocks != ""} {
-        BrowseCIF $allblocks "" .cif
-        # wait for the window to close
-        tkwait window .cif
-    } else {
-        puts "no blocks read"
-    }
-    # clean up -- get rid of the CIF arrays
-    for {set i 1} {$i <= $blocks} {incr i} {
-        global block$i
-        unset block$i
-    }
-}