Changeset 646

Timestamp:

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

Author:

toby

Message:

# on 2002/09/05 18:24:04, toby did:
add categories to loops
improve number parsing
lock edits in text window
(above grew from suggestions by B. McMahon?)

File:

• trunk/browsecif.tcl (modified) (23 diffs, 3 props)

trunk/browsecif.tcl

@@ -297 +297 @@
     toplevel .msg
     wm transient .msg [winfo toplevel .]
-    pack [frame .msg.f -bd 4 -relief groove]
+    pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
     pack [message .msg.f.m -text "Please wait $message"]
     wm withdraw .msg
@@ -400 +400 @@
 # the contents of each loop are saved as blockN(loop_M)
 #
+# if the filename is blank or not specified, the current contents
+#    of the text widget, $txt, is parsed.
+#
 # The proc returns the number of blocks that have been read or a
 #    null string if the file cannot be opened
@@ -406 +409 @@
 #    but the parser could get confused if the CIF has invalid syntax
 #
-proc ParseCIF {txt filename} {
+proc ParseCIF {txt "filename {}"} {
     global CIF tcl_version
+    global CIF_dataname_index
 
     if {$tcl_version < 8.2} {
@@ -416 +420 @@
     }
 
-    if [catch {
-        set fp [open $filename r]
-        $txt insert end [read $fp]
-        close $fp
-    }] {return ""}
+    if {$filename != ""} {
+        if [catch {
+            $txt configure -state normal
+            set fp [open $filename r]
+            $txt insert end [read $fp]
+            close $fp
+            $txt configure -state disabled
+        }] {
+            return ""
+        }
+    }
+
 
     set pos 1.0
@@ -486 +497 @@
                 # in a loop header, save the names in the loop list
                 lappend looplist $dataname
+                # check the categories used in the loop
+                set category {}
+                catch {
+                    set category [lindex \
+                            [lindex $CIF_dataname_index($dataname) 1] 5]
+                }
+                # don't worry if we don't have a category
+                if {$category != ""} {
+                    if {$catlist == ""} {
+                        set catlist $category
+                    } elseif {[lsearch $catlist $category] == -1} {
+                        # error two categories in a loop
+                        lappend catlist $category
+                        append block${blocks}(errors) \
+                                "Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n"
+                    }
+                }
+                
                 if {$blocks == 0} {
                     # an error -- a loop_ before a data_ block start
@@ -519 +548 @@
             incr loopnum
             set looplist {}
+            set catlist {}
             set block${blocks}(loop_${loopnum}) {}
             # move forward past current token
@@ -675 +705 @@
 #    frame gives the name of the toplevel or frame to hold the browser
 proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} {
-    global CIF CIFtreeindex
+    global CIF CIFtreeindex CIF_dataname_index
 
     if {$selected == ""} {set selected $blocklist}
@@ -722 +752 @@
         }
         foreach loop [lsort [array names block$n loop_*]] {
-            $CIF(tree) insert end block$n block${n}$loop -text $loop \
+            # make a list of categories used in the loop
+            set catlist {}
+            foreach name [lsort [set block${n}($loop)]] {
+                set category {}
+                catch {
+                    foreach {type range elist esd units category} \
+                            [lindex $CIF_dataname_index($name) 1] {}
+                }
+                if {$category != "" && [lsearch $catlist $category] == -1} {
+                    lappend catlist $category
+                }
+            }
+
+            $CIF(tree) insert end block$n block${n}$loop \
+                    -text "$loop ($catlist)" \
                     -image [Bitmap::get file] -data "block$n loop"
             set CIFtreeindex(block${n}$loop) block${n}$loop
@@ -826 +870 @@
     if {[CheckForCIFEdits]} return
     set pointer [$CIF(tree) itemcget $name -data]
-    set dataname [$CIF(tree) itemcget $name -text]
+    set dataname [lindex [$CIF(tree) itemcget $name -text] 0]
     showCIFbyDataname $pointer $dataname
 }
@@ -992 +1036 @@
 }
 
-# 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
+# scan a number in crystallographic uncertainty representation
+# i.e.: 1.234(12), 1234(23), 1.234e-2(14),  -1.234-08(14), etc.
+proc ParseSU {num} {
+    # is there an error on this value?
+    if {![regexp {([-+eEdD.0-9]+)\(([0-9]+)\)} $num x a err]} {
+        set a $num
+        set err {}
+    }
+    # parse off an exponent, if present
+    if {[regexp {([-+.0-9]+)[EeDd]([-+0-9]+)} $a x a1 exp]} {
+        # [+-]###.###e+## or [+-]###.###D-## etc.
+        set a $a1
+        # remove leading zeros from exponent
+        regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
+    } elseif {[regexp {([-+.0-9]+)([-+][0-9]+)} $a x a1 exp]} {
+        # [+-]###.###+## or [+-]###.###-## etc. [no 
+        set a $a1
+        # remove leading zeros from exponent
+        regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
+    } else {
+        set exp 0
+    }
+    # now parse the main number and count the digits after the decimal
+    set a2 {}
+    set a3 {}
+    regexp {^([-+0-9]*)\.?([0-9]*)$} $a x a2 a3
+    set l [string length $a3]
+
+    set val .
+    set error {}
+    if {[catch {
+        set val [expr ${a2}.${a3} * pow(10,$exp)]
+        if {$err != ""} {
+            set error [expr $err*pow(10,$exp-$l)]
+        }
+    }]} {
+        # something above was invalid
+        if {$err != ""} {
+            return "$val ."
+        } else {
+            return $val
+        }
+    }
+    if {$error == ""} {
+        return $val
+    } else {
+        return [list $val $error]
+    }
 }
 
@@ -1027 +1101 @@
     if {$file == ""} return
     if {![file exists $file]} return
-    pleasewait "Reading CIF file"
+    pleasewait "Reading CIF from file"
     set blocks [ParseCIF $file]
     if {$blocks == ""} {
@@ -1077 +1151 @@
 # exceed 80 characters/line
 proc ReplaceMarkedText {txt mark value} {
+    $txt configure -state normal
     # is this a multi-line string?
     set num [string first \n $value]
@@ -1114 +1189 @@
         $txt delete ${mark}.l ${mark}.r
         $txt insert ${mark}.l $tmp
+        $txt configure -state disabled
         return
     } elseif {($spaces != -1 || [string trim $value] == "") \
@@ -1145 +1221 @@
         $txt insert $mark.r \n
     }
+    $txt configure -state disabled
 }
 
@@ -1222 +1299 @@
     if {[
         catch {
-            foreach {type range elist esd units} [lindex $CIF_dataname_index($dataname) 1] {}
+            foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
         }
     ]} {return "warning: dataname $dataname not defined"}
@@ -1279 +1356 @@
     global CIF
     set deflist [GetCIFDefinitions $defs]
-    $CIF(defBox) delete 1.0 end
-    foreach d $deflist {
-        foreach {namelist definition} $d {}
-        foreach n $namelist {
-            $CIF(defBox) insert end $n dataname
+    catch {
+        $CIF(defBox) delete 1.0 end
+        foreach d $deflist {
+            foreach {namelist definition} $d {}
+            foreach n $namelist {
+                $CIF(defBox) insert end $n dataname
+                $CIF(defBox) insert end \n
+            }
             $CIF(defBox) insert end \n
-        }
-        $CIF(defBox) insert end \n
-        $CIF(defBox) insert end $definition
-        $CIF(defBox) insert end \n
-        $CIF(defBox) insert end \n
-    }
-    $CIF(defBox) tag config dataname -background yellow
+            $CIF(defBox) insert end $definition
+            $CIF(defBox) insert end \n
+            $CIF(defBox) insert end \n
+        }
+        $CIF(defBox) tag config dataname -background yellow
+    }
 }
 
@@ -1300 +1379 @@
     if {[
         catch {
-            foreach {type range elist esd units} [lindex $CIF_dataname_index($dataname) 1] {}
+            foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
         }
     ]} {
@@ -1512 +1591 @@
     if {[CheckForCIFEdits]} return
 
+    $CIF(txt) configure -state normal
     set looplist [set ${block}($loop)]
     set length [llength [set ${block}([lindex $looplist 0])]]
@@ -1548 +1628 @@
     $CIF(LoopSpinBox) setvalue last
     ShowLoopVar $block $loop
+    $CIF(txt) configure -state disabled
 }
 
@@ -1593 +1674 @@
     if {$ans == "keep"} {return}
 
+    $CIF(txt) configure -state normal
     foreach widget $CIF(widgetlist) {
         foreach {dataname block index} $CIFinfoArr($widget) {}
@@ -1600 +1682 @@
         set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
     }
+    $CIF(txt) configure -state disabled
 
     set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
@@ -1605 +1688 @@
     $CIF(LoopSpinBox) configure -range "1 $max 1"
     $CIF(LoopSpinBox) setvalue last
+}
+
+# display & highlight a line in the CIF text viewer
+proc MarkGotoLine {line} {
+    global CIF
+    $CIF(txt) tag delete currentline
+    $CIF(txt) tag add currentline $line.0 $line.end
+    $CIF(txt) tag configure currentline -foreground blue
+    $CIF(txt) see $line.0
+}
+
+# Extract a value from a CIF in the  CIF text viewer
+proc ValueFromCIF {block item} {
+    global $block CIF
+    set val {}
+    catch {
+        set mark [set ${block}($item)]
+        if {[llength $mark] == 1} {
+            set val [string trim [StripQuotes [$CIF(txt) get $mark.l $mark.r]]]
+        } else {
+            foreach m $mark {
+                lappend val [string trim [StripQuotes [$CIF(txt) get $m.l $m.r]]]
+            }
+        }
+    }
+    return $val
 }
 
@@ -1614 +1723 @@
 set CIF(lastLoopIndex) {}
 set CIF(autosave_edits) 0
+set CIF(editmode) 0