Changeset 285 for trunk/import_cif.tcl


Ignore:
Timestamp:
Dec 4, 2009 5:03:30 PM (14 years ago)
Author:
toby
Message:

# on 2000/09/26 14:51:04, toby did:
Various fixes: change data names to all lower case
better error detection
use " or ' quoted strings
fix semicolon recognition -- now characters after ending ; are parsed
improve comments
Add Read_BrowseCIF proc for debug and possibly other use

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/import_cif.tcl

    • Property rcs:date changed from 2000/09/24 04:41:00 to 2000/09/26 14:51:04
    • Property rcs:rev changed from 1.1 to 1.2
    • Property rcs:lines set to +155 -48
    r280 r285  
    6868    set msg {}
    6969    catch {
    70         set spg [set block${i}(_symmetry_space_group_name_H-M)]
     70        set spg [set block${i}(_symmetry_space_group_name_h-m)]
    7171        regsub -all {'} $spg {} spg
    7272        # see if this space group exists in the table
    … …  
    8787    foreach var {_cell_length_a _cell_length_b _cell_length_c \
    8888            _cell_angle_alpha _cell_angle_beta _cell_angle_gamma} {
    89         # leave blank any unspecified values
     89        # leave blank any unspecified data items
    9090        set val {}
    9191        catch {set val [set block${i}($var)]}
    … …  
    100100    set uisolist {}
    101101    catch {
    102         set uisolist [set block${i}(_atom_site_U_iso_or_equiv)]
     102        set uisolist [set block${i}(_atom_site_u_iso_or_equiv)]
    103103        set Uconv 1
    104104    }
    105105    if {$uisolist == ""} {
    106         set uisolist [set block${i}(_atom_site_B_iso_or_equiv)]
     106        set uisolist [set block${i}(_atom_site_b_iso_or_equiv)]
    107107        set Uconv [expr 1/(8*3.14159*3.14159)]
    108108    }
    … …  
    153153# each block into arrays block1, block2,... in the caller's level
    154154#    the name of the block is saved as blockN(data_)
    155 # data items are saved as blockN(_cif_name) = value
    156 #    values are not reformatted, thus quotes, semicolons & newlines
    157 #    are included in the value string
    158 # for looped data items, the values are included in a list:
    159 #    blockN(_cif_name) = {value list ...}
     155# data names and items are saved as blockN(_data_name) = {data item}
     156#    data items are not reformatted, thus quotes, semicolons & newlines
     157#    are included in the data item string
     158#    CIF names are converted to lower case
     159# for looped data names, the data items are included in a list:
     160#    blockN(_cif_name) = {item1 "item2 with spaces" item3 ...}
    160161# the contents of each loop are saved as blockN(loop_M)
    161162#
    162 # the proc returns the number of blocks that have been read or a
    163 # null string if the file cannot be opened
     163# The proc returns the number of blocks that have been read or a
     164#    null string if the file cannot be opened
     165#
     166# This parser does some error checking [errors are reported in blockN(error)]
     167#    but the parser could get confused if the CIF has invalid syntax
     168#
    164169proc ParseCIF {filename} {
    165170    if [catch {
    … …  
    170175    set EOF 1
    171176    set line {}
     177    set dataname {}
     178    # line counter (for error messages)
     179    set linenum 0
     180    # this flags where we are w/r a loop_
     181    #    -1 not in a loop
     182    #     0 reading a loop header (data names)
     183    #     1 reading the data items in a loop
    172184    set loopflag -1
     185    set loopnum -1
    173186    # loop over tokens
    174187    while {$EOF} {
     188        # read the next line, unless we have a holdover from the previous
    175189        if {[string length [string trim $line]] <= 0} {
     190            incr linenum
    176191            if {[gets $fp line] < 0} {set EOF 0}
    177192        }
     193        # flag if the string \' has been replaced
    178194        set hidden 0
    179195        set trimline [string trim $line]
    … …  
    209225           
    210226            if {$line == ""} continue
    211             set dataname {}
     227            if {$dataname != ""} {
     228                # this is an error -- data_ block where a data item is expected
     229                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
     230                set dataname {}
     231            }
    212232        }
    213233       
    214234        if {$firstchar == "_"} {
    215             # this is a data item
    216             # are there other tokens on this line?
     235            # this is a cif data name
     236            if {$dataname != ""} {
     237                # this is an error -- data name where a data item is expected
     238                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
     239            }
     240            # parse it out & convert it to lower case
    217241            if {[set pos [string first { } $trimline]] == -1} {
    218                 set dataname $trimline
     242                # nothing else is on this line
     243                set dataname [string tolower $trimline]
    219244                set line {}
    220245            } else {
     246                # There other tokens on this line
    221247                set dataname [string range $trimline 0 [expr $pos-1]]
    222                 set line [string range $trimline $pos end]
     248                set line [string tolower [string range $trimline $pos end]]
    223249            }
    224250           
    225251            if {$loopflag == 0} {
    226                 # in a loop header, save the names in the loop
     252                # in a loop header, save the names in the loop list
    227253                lappend looplist $dataname
    228254                set block${blocks}(loop_${loopnum}) $looplist
    229                 # clear the data item -- should not be needed, but...
     255                # clear the array element for the data item
     256                # -- should not be needed for a valid CIF but if a name is used
     257                # -- twice in the same block, want to wipe out the 1st data
    230258                set block${blocks}($dataname) {}
    231259                set dataname {}
    … …  
    247275        }
    248276
    249         # keywords not matched, must be some type of value item
     277        # keywords not matched, must be some type of data item
    250278        set item {}
    251279       
    252         # multiline entry with semicolon termination
    253280        if {[string index $line 0] == ";"} {
     281            # multiline entry with semicolon termination
    254282            set item $line
    255283            # read lines until we get a naked semicolon
    256284            while {$EOF} {
     285                incr linenum
    257286                if {[gets $fp line] < 0} {set EOF 0}
    258                 append item \n $line
    259                 if {[string index $line 0] == ";" && \
    260                         [string trim [string range $line 1 end]] == ""} break
    261             }
    262             set line {}
     287                if {[string index $line 0] == ";"} {
     288                    append item "\n;"
     289                    # make sure the line has a blank in front, so
     290                    # a semicolon in col 2 is not treated as a quote character
     291                    set line " [string range $line 1 end]"
     292                    break
     293                }
     294            }
     295            if {[string trim $line] == ""} {set line ""}
     296        } elseif {$firstchar == {"}} {
     297            # a quoted string
     298            # hide any \" sequences in a non-ASCII character (\201)
     299            set hidden [regsub -all {\\"} $trimline \201 trimline]
     300            # parse out the quoted string, save the remainder
     301            if {![regexp {("[^"]*")(.*)} $trimline junk item line]} {
     302                # this is an error -- no end-quote was found
     303                set item $line
     304                set line {}
     305                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
     306            }
    263307        } elseif {$firstchar == {'}} {
    264             # hide any \' sequences in a non-ASCII character
     308            # a quoted string
     309            # hide any \' sequences in a non-ASCII character (\200)
    265310            set hidden [regsub -all {\\'} $trimline \200 trimline]
    266             regexp {('[^']*')(.*)} $trimline junk item line
     311            # parse out the quoted string, save the remainder
     312            if {![regexp {('[^']*')(.*)} $trimline junk item line]} {
     313                # this is an error -- no end-quote was found
     314                set item $line
     315                set line {}
     316                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
     317            }
    267318        } else {
     319            # must be a single space-delimited value
    268320            set pos [string first { } $trimline]
    269321            if {$pos < 0} {
     322                # and the only thing left on the line
    270323                set item $trimline
    271324                set line {}
    272325            } else {
     326                # save the rest of the line
    273327                set line [string range $trimline $pos end]
    274328                incr pos -1
    … …  
    277331        }
    278332       
    279         # a data value has been read
     333        # a data item has been read
     334        # fix the hidden characters, if any
    280335        if $hidden {
    281336            regsub -all \200 $item {\\'} item
    282         }
    283 
    284         # if in a loop, increment the loop element counter
     337            regsub -all \201 $item {\\"} item
     338        }
     339
     340        # store the data item
    285341        if {$loopflag >= 0} {
     342            # if in a loop, increment the loop element counter to select the
     343            # appropriate array element
    286344            incr loopflag
    287345            set i [expr ($loopflag - 1) % [llength $looplist]]
    288346            lappend block${blocks}([lindex $looplist $i]) $item
     347        } elseif {$dataname == ""} {
     348            # this is an error -- a data item where we do not expect one
     349            append block${blocks}(errors) "The string \"$item\" on line $linenum was unexpected\n"
    289350        } else {
    290351            set block${blocks}($dataname) $item
     352            set dataname ""
    291353        }
    292354    }
    … …  
    339401    foreach n $blocklist {
    340402        global block$n
    341         # make a list of data items in loops
     403        # make a list of data names in loops
    342404        set looplist {}
    343405        foreach loop [array names block$n loop_*] {
    … …  
    350412        $tree insert end root block$n -text "_data_$blockname" \
    351413                -open $open -image [Bitmap::get copy]
    352         # loop over the items in each block
    353         foreach item [array names block$n _*] {
    354             # don't include looped items
    355             if {[lsearch $looplist $item] == -1} {
    356                 $tree insert end block$n [incr num] -text $item \
     414        # loop over the names in each block
     415        foreach name [array names block$n _*] {
     416            # don't include looped names
     417            if {[lsearch $looplist $name] == -1} {
     418                $tree insert end block$n [incr num] -text $name \
    357419                        -image [Bitmap::get folder] -data block$n
    358420            }
    … …  
    361423            $tree insert end block$n block${n}$loop -text $loop \
    362424                    -image [Bitmap::get file] -data "block$n loop"
    363             foreach item [set block${n}($loop)] {
    364                 $tree insert end block${n}$loop [incr num] -text $item \
     425            foreach name [set block${n}($loop)] {
     426                $tree insert end block${n}$loop [incr num] -text $name \
    365427                        -image [Bitmap::get folder] -data "block$n $loop"
    366428            }
     429        }
     430        foreach name [array names block$n errors] {
     431            $tree insert end block$n [incr num] -text $name \
     432                    -image [Bitmap::get undo] -data block$n
    367433        }
    368434    }
    … …  
    387453
    388454# used in BrowseCIF in response to the clicking on a CIF dataname
    389 # shows the contents data item or a loop
    390 proc showCIFvalue {tree sw item} {
    391     set data [$tree itemcget $item -data]
    392     set text [$tree itemcget $item -text]
     455# shows the contents data name or a loop
     456proc showCIFvalue {tree sw name} {
     457    set data [$tree itemcget $name -data]
     458    set text [$tree itemcget $name -text]
    393459
    394460    # delete old contents of frame
    … …  
    410476        if {[lindex $data 1] == "loop"} {
    411477            set looplist [set [lindex $data 0]($text)]
    412             # get number of elements for first item
    413             set items [llength [set [lindex $data 0]([lindex $looplist 0])]]
     478            # get number of elements for first name
     479            set names [llength [set [lindex $data 0]([lindex $looplist 0])]]
    414480            set sb $frame.spin
    415             grid [SpinBox $sb -range "1 $items 1" \
     481            grid [SpinBox $sb -range "1 $names 1" \
    416482                    -label "Loop\nelement #" -labelwidth 10 -width 10 \
    417483                    -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
    … …  
    419485                    -column 0 -row 0 -sticky w
    420486            set i 0
    421 #           grid columnconfig $frame 0 -minsize 250
    422487            foreach var $looplist {
    423488                incr i
    … …  
    433498            set frame0 [$frame.0 getframe]
    434499            grid columnconfig $frame0 2 -weight 1
    435             foreach item [set [lindex $data 0]($text)] {
     500            foreach name [set [lindex $data 0]($text)] {
    436501                incr row
    437502                grid [label $frame0.a$row -justify left -text $row]\
    438503                        -sticky w -column 0 -row $row
    439504                grid [label $frame0.b$row -bd 2 -relief groove \
    440                         -justify left -anchor w -text $item]\
     505                        -justify left -anchor w -text $name]\
    441506                        -sticky new -column 1 -row $row
    442507            }
    443508        }
    444509    } else {
    445         # unlooped data item
     510        # unlooped data name
    446511        global [lindex $data 0]
    447512        grid [TitleFrame $frame.0 -text $text -side left] \
    … …  
    450515                -text [set ${data}($text)]] -side left
    451516    }
    452 #    $lf configure -text $text
    453517}
    454518
    … …  
    472536            warning 0 Continue
    473537}
     538
     539# a stand-alone routine for testing. Select, read and browse a CIF
     540proc Read_BrowseCIF {} {
     541    global tcl_platform
     542    if {$tcl_platform(platform) == "windows"} {
     543        set filetypelist {
     544            {"CIF files" .CIF} {"All files" *}
     545        }
     546    } else {
     547        set filetypelist {
     548            {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
     549        }
     550    }   
     551    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
     552    if {$file == ""} return
     553    if {![file exists $file]} return
     554    # plasewait and donewait are defined in gsascmds.tcl and may not be present
     555    catch {pleasewait "Reading CIF file"}
     556    set blocks [ParseCIF $file]
     557    if {$blocks == ""} {
     558        donewait
     559        MessageBox -parent . -type ok -icon warning \
     560                -message "Note: no valid CIF blocks were read from file $filename"
     561        return
     562    }
     563    catch {donewait}
     564    set allblocks {}
     565    for {set i 1} {$i <= $blocks} {incr i} {
     566        lappend allblocks $i
     567    }
     568    if {$allblocks != ""} {
     569        BrowseCIF $allblocks "" .cif
     570        # wait for the window to close
     571        tkwait window .cif
     572    } else {
     573        puts "no blocks read"
     574    }
     575    # clean up -- get rid of the CIF arrays
     576    for {set i 1} {$i <= $blocks} {incr i} {
     577        global block$i
     578        unset block$i
     579    }
     580}
Note: See TracChangeset for help on using the changeset viewer.