Changeset 771


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

# on 2004/01/30 00:41:19, toby did:
update to match new version of CIFEDIT etc.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/browsecif.tcl

    • Property rcs:date changed from 2003/11/13 17:20:00 to 2004/01/30 00:41:19
    • Property rcs:lines changed from +1 -1 to +1306 -46
    • Property rcs:rev changed from 1.8 to 1.9
    r747 r771  
    394394}
    395395
     396proc putontop {w "center 0"} {
     397    # center window $w above its parent and make it stay on top
     398    set wp [winfo parent $w]
     399    wm transient $w [winfo toplevel $wp]
     400    wm withdraw $w
     401    update idletasks
     402    if {$center} {
     403        set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
     404                - [winfo vrootx [winfo parent $w]]}]
     405        set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
     406                - [winfo vrooty [winfo parent $w]]}]
     407    } else {
     408        # center the new window in the middle of the parent
     409        set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
     410                [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
     411        if {$x < 0} {set x 0}
     412        set xborder 10
     413        if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
     414            incr x [expr [winfo screenwidth $w] - \
     415                    ($x+[winfo reqwidth $w] + $xborder)]
     416        }
     417        set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
     418                [winfo reqheight $w]/2 - [winfo vrooty $wp]]
     419        if {$y < 0} {set y 0}
     420        set yborder 25
     421        if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
     422            incr y [expr [winfo screenheight $w] - \
     423                    ($y+[winfo reqheight $w] + $yborder)]
     424        }
     425    }
     426    wm geometry $w +$x+$y
     427    wm deiconify $w
     428
     429    global makenew
     430    set makenew(OldGrab) ""
     431    set makenew(OldFocus) ""
     432    catch {set makenew(OldFocus) [focus]}
     433    catch {set makenew(OldGrab) [grab current $w]}
     434    catch {grab $w}
     435}
     436
     437proc afterputontop {} {
     438    # restore focus
     439    global makenew
     440    # reset focus & grab
     441    catch {
     442        if {$makenew(OldFocus) != ""} {
     443            focus $makenew(OldFocus)
     444        }
     445    }
     446    catch {
     447        if {$makenew(OldGrab) != ""} {
     448            grab $makenew(OldGrab)
     449        }
     450    }
     451}
     452
    396453#------------------------------------------------------------------------------
    397454# end of Misc Tcl/Tk utility routines
    … …  
    418475#    but the parser could get confused if the CIF has invalid syntax
    419476#
    420 proc ParseCIF {txt "filename {}"} {
     477proc ParseCIF {txt "filename {}" "namespace {}"} {
    421478    global CIF tcl_version
    422479    global CIF_dataname_index
     480    # create a namespace, if one is needed
     481    if {$namespace != ""} {
     482        namespace eval $namespace {}
     483    }
    423484
    424485    if {$tcl_version < 8.2} {
    … …  
    506567            incr blocks
    507568            set blockname [string range $token 5 end]
    508             global block$blocks
    509             catch {unset block$blocks}
    510             set block${blocks}(data_) $blockname
     569            catch {unset ${namespace}::block$blocks}
     570            set ${namespace}::block${blocks}(data_) $blockname
    511571            set loopnum -1
    512572            if {$dataname != ""} {
    513573                # this is an error -- data_ block where a data item is expected
    514                 append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
     574                append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
    515575                set dataname {}
    516576            }
    … …  
    524584            if {$dataname != ""} {
    525585                # this is an error -- data name where a data item is expected
    526                 append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
     586                append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
    527587            }
    528588            # convert it to lower case & save
    … …  
    546606                        # error two categories in a loop
    547607                        lappend catlist $category
    548                         append block${blocks}(errors) \
     608                        append ${namespace}::block${blocks}(errors) \
    549609                                "Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n"
    550610                    }
    … …  
    553613                if {$blocks == 0} {
    554614                    # an error -- a loop_ before a data_ block start
    555                     global block${blocks}
    556                     set block${blocks}(data_) undefined
    557                     append block${blocks}(errors) \
     615                    set ${namespace}::block${blocks}(data_) undefined
     616                    append ${namespace}::block${blocks}(errors) \
    558617                            "A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n"
    559618                }
    560                 set block${blocks}(loop_${loopnum}) $looplist
     619                set ${namespace}::block${blocks}(loop_${loopnum}) $looplist
    561620                # clear the array element for the data item
    562621                # -- should not be needed for a valid CIF but if a name is used
    563622                # -- twice in the same block, want to wipe out the 1st data
    564623                catch {
    565                     if {[set block${blocks}($dataname)] != ""} {
     624                    if {[set ${namespace}::block${blocks}($dataname)] != ""} {
    566625                        # this is an error -- repeated data name
    567                         append block${blocks}(errors) \
     626                        append ${namespace}::block${blocks}(errors) \
    568627                                "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
    569628                    }   
    570                     set block${blocks}($dataname) {}
     629                    set ${namespace}::block${blocks}($dataname) {}
    571630                }
    572631                set dataname {}
    … …  
    585644            set looplist {}
    586645            set catlist {}
    587             set block${blocks}(loop_${loopnum}) {}
     646            set ${namespace}::block${blocks}(loop_${loopnum}) {}
    588647            # move forward past current token
    589648            set pos [$txt index "$epos +1c"]
    … …  
    601660            if {$epos == ""} {
    602661                set epos end
    603                 append block${blocks}(errors) \
     662                append ${namespace}::block${blocks}(errors) \
    604663                        "Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n"
    605664            }
    … …  
    623682            if {$epos == ""} {
    624683                set epos [$txt index "$pos lineend"]
    625                 append block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
     684                append ${namespace}::block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
    626685            }
    627686            $txt mark set $CIF(markcount).l "$pos"
    … …  
    643702            if {$epos == ""} {
    644703                set epos [$txt index "$pos lineend"]
    645                 append block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
     704                append ${namespace}::block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
    646705            }
    647706            $txt mark set $CIF(markcount).l "$pos"       
    … …  
    660719                if {$epos == ""} {
    661720                    # unmatched open square bracket
    662                     append block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n"
     721                    append ${namespace}::block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n"
    663722                    set count 0
    664723                    set epos [$txt index end]
    … …  
    695754            incr loopflag
    696755            set i [expr ($loopflag - 1) % [llength $looplist]]
    697             lappend block${blocks}([lindex $looplist $i]) $CIF(markcount)
     756            lappend ${namespace}::block${blocks}([lindex $looplist $i]) $CIF(markcount)
     757            set ${namespace}::block${blocks}(lastmark) $CIF(markcount)
    698758        } elseif {$dataname == ""} {
    699759            # this is an error -- a data item where we do not expect one
    700             append block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n"
     760            append ${namespace}::block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n"
    701761        } else {
    702762            if {$blocks == 0} {
    703763                # an error -- a data name before a data_ block start
    704                 global block${blocks}
    705                 set block${blocks}(data_) undefined
    706                 append block${blocks}(errors) \
     764                set ${namespace}::block${blocks}(data_) undefined
     765                append ${namespace}::block${blocks}(errors) \
    707766                            "Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n"
    708767            }
    709768            catch {
    710                 if {[set block${blocks}($dataname)] != ""} {
     769                if {[set ${namespace}::block${blocks}($dataname)] != ""} {
    711770                    # this is an error -- repeated data name
    712                     append block${blocks}(errors) \
     771                    append ${namespace}::block${blocks}(errors) \
    713772                            "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
    714773                }
    715774            }
    716             set block${blocks}($dataname) $CIF(markcount)
     775            set ${namespace}::block${blocks}($dataname) $CIF(markcount)
     776            set ${namespace}::block${blocks}(lastmark) $CIF(markcount)
    717777            set dataname ""
    718778        }
    … …  
    798858                set category {}
    799859                catch {
    800                     foreach {type range elist esd units category} \
    801                             [lindex $CIF_dataname_index($name) 1] {}
     860                    set category [lindex \
     861                            [lindex $CIF_dataname_index($name) 1] 5]
    802862                }
    803863                if {$category != "" && [lsearch $catlist $category] == -1} {
    … …  
    11951255}
    11961256
    1197 # a stand-alone routine for testing. Select, read and browse a CIF
     1257# a stand-alone routine for testing: Select, read and browse a CIF
    11981258proc Read_BrowseCIF {} {
    11991259    global tcl_platform
    … …  
    12281288        tkwait window .cif
    12291289    } else {
    1230         catch {puts "no blocks read"}
     1290        puts "no blocks read"
    12311291    }
    12321292    # clean up -- get rid of the CIF arrays
    … …  
    13551415    set pp {}
    13561416    set dictdefs {}
    1357     set def {}
     1417    set def {start}
    13581418    set nlist {}
    13591419    # merge items with duplicate definitions
    … …  
    13611421        # is this the first loop through?
    13621422        foreach {dataname pointer} $item {}
    1363         if {$def == ""} {
     1423        if {$def == "start"} {
    13641424            foreach {nlist pp} $item {}
    13651425            set def [ReadCIFDefinition $pp]
    … …  
    13691429        } else {
    13701430            # add the last entry to the list
     1431            set file [lindex $pp 0]
    13711432            set pp $pointer
    1372             lappend dictdefs [list $nlist $def]
     1433            lappend dictdefs [list $nlist $def $file]
    13731434            set nlist $dataname
    13741435            if {$pointer == ""} {
    … …  
    13801441        }
    13811442    }
    1382     lappend dictdefs [list $nlist $def]
     1443    set file [lindex $pointer 0]
     1444    lappend dictdefs [list $nlist $def $file]
    13831445    return $dictdefs
    13841446}
    … …  
    13881450# the length of the definition.
    13891451proc ReadCIFDefinition {pointer} {
    1390     global CIF
     1452    global CIF CIF_file_paths
    13911453    set file {}
    13921454    set loc {}
    … …  
    13951457    if {$file != "" && $loc != "" && $loc != ""} {
    13961458        set fp {}
    1397         foreach path $CIF(cif_path) {
    1398             catch {set fp [open [file join $path $file] r]}
    1399             if {$fp != ""} break
     1459        if {[array names CIF_file_paths $file] != ""} {
     1460            catch {set fp [open $CIF_file_paths($file) r]}
     1461            if {$fp == ""} return
     1462        } elseif {[array names CIF_file_paths] != ""} {
     1463            return
     1464        } else {
     1465            # support legacy applications using CIF(cif_path)
     1466            foreach path $CIF(cif_path) {
     1467                catch {set fp [open [file join $path $file] r]}
     1468                if {$fp != ""} break
     1469            }
    14001470        }
    14011471        if {$fp == ""} return
    … …  
    14311501    catch {set maxlinelength $CIF(maxlinelength)}
    14321502    if {[catch {
    1433         foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
     1503        foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {}
    14341504    }]} {return}
    14351505    if {$type == "c"} {
    … …  
    15131583        $CIF(defBox) delete 1.0 end
    15141584        foreach d $deflist {
    1515             foreach {namelist definition} $d {}
     1585            foreach {namelist definition file} $d {}
    15161586            foreach n $namelist {
    15171587                $CIF(defBox) insert end $n dataname
    … …  
    15191589            }
    15201590            $CIF(defBox) insert end \n
    1521             $CIF(defBox) insert end $definition
    1522             $CIF(defBox) insert end \n
    1523             $CIF(defBox) insert end \n
     1591            if {$definition == ""} {
     1592                $CIF(defBox) insert end "No definition found\n\n"
     1593            } else {
     1594                $CIF(defBox) insert end $definition
     1595                $CIF(defBox) insert end "\n\[$file\]\n\n"
     1596            }
     1597
    15241598        }
    15251599        $CIF(defBox) tag config dataname -background yellow
    … …  
    15331607    if {[
    15341608        catch {
    1535             foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
     1609            foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {}
    15361610        }
    15371611    ]} {
    … …  
    20282102}
    20292103
     2104# create a category browser to select a single CIF item (mode=single)
     2105# or to populate a loop_ (mode=multiple)
     2106proc CatBrowserWindow {parent "mode multiple"} {
     2107    global CIF CIF_dataname_index
     2108    global catlist
     2109    if {$mode == "multiple"} {
     2110        set CIF(catselectmode) 1
     2111    } else {
     2112        set CIF(catselectmode) 0
     2113    }
     2114    set CIF(CategoryBrowserWin) [set frame $parent.catselect]
     2115    if {[winfo exists $frame]} {
     2116        set CIF(searchtext) ""
     2117        # the window exists so go ahead and use it
     2118        set CIF(SelCat) {}
     2119        set CIF(CatSelList) {}
     2120        set CIF(CatSelItems) {}
     2121        wm deiconify $frame
     2122        $CIF(cattree) selection clear
     2123        tkwait variable CIF(CatSelectDone)
     2124        wm withdraw $frame
     2125        return
     2126    }
     2127    catch {unset catlist}
     2128    set CIF(searchtext) ""
     2129    pleasewait "building category window" "" $parent
     2130    # create an index by category
     2131    foreach name [lsort [array names CIF_dataname_index]] {
     2132        set category [lindex [lindex $CIF_dataname_index($name) 1] 5]
     2133        lappend catlist($category) $name
     2134    }
     2135    catch {destroy $frame}
     2136    toplevel $frame
     2137    wm withdraw $frame
     2138    wm title $frame "CIF Category Browser"
     2139    wm protocol $frame WM_DELETE_WINDOW "set CIF(CatSelItems) {}; set CIF(CatSelectDone) Q"
     2140    if {$CIF(catselectmode)} {
     2141        set text "Select one or more data names in a\nsingle category to create a new loop"
     2142    } else {
     2143        set text "Select a single data name to add to the CIF"
     2144    }
     2145    grid [frame $frame.top -bg beige] -sticky news -column 0 -row 0
     2146    grid columnconfigure $frame.top 0 -weight 1
     2147    grid columnconfigure $frame.top 1 -pad 10
     2148    grid [label $frame.top.1 -text $text -bg beige] \
     2149            -sticky news -column 0 -row 0
     2150    grid [set CIF(usebutton) [button $frame.top.use -text "Insert" \
     2151            -command "set CIF(CatSelectDone) done" \
     2152            -state disabled]] -column 1 -row 0
     2153    grid [frame $frame.bot] -sticky news -column 0 -row 2
     2154    grid [label $frame.bot.txt -text "Enter search text:"] \
     2155            -column 0 -row 1
     2156    grid [entry $frame.bot.e -textvariable CIF(searchtext)] \
     2157            -column 1 -row 1
     2158    bind $frame.bot.e <Return> CatLookupName
     2159    grid [button $frame.bot.src -text "Search" \
     2160            -command CatLookupName] -column 2 -row 1
     2161    grid [button $frame.bot.next -text "Next" -command ShowNextcatSearch] \
     2162            -column 3 -row 1
     2163    grid [button $frame.bot.q -text Quit \
     2164            -command "set CIF(CatSelItems) {}; set CIF(CatSelectDone) Q"\
     2165            ] -column 5 -row 1
     2166    set sw    [ScrolledWindow $frame.lf]
     2167    $frame.lf configure -relief sunken -borderwidth 2
     2168    set CIF(cattree) [Tree $sw.tree -relief flat -borderwidth 0 -width 45 \
     2169            -highlightthickness 0 -redraw 1 -height 20]
     2170    # get the size of the font and adjust the line spacing accordingly
     2171    catch {
     2172        set font [option get $CIF(cattree) font Canvas]
     2173        $CIF(cattree) configure -deltay [font metrics $font -linespace]
     2174    }
     2175    grid $sw -sticky news -column 0 -row 1
     2176    grid columnconfigure $frame 0 -minsize 275 -weight 1
     2177    grid rowconfigure $frame 1 -weight 1
     2178    $sw setwidget $CIF(cattree)
     2179   
     2180    bind $frame <KeyPress-Prior> "$CIF(cattree) yview scroll -1 page"
     2181    bind $frame <KeyPress-Next> "$CIF(cattree) yview scroll 1 page"
     2182    bind $frame <KeyPress-Up> "$CIF(cattree) yview scroll -1 unit"
     2183    bind $frame <KeyPress-Down> "$CIF(cattree) yview scroll 1 unit"
     2184    bind $frame <KeyPress-Home> "$CIF(cattree) yview moveto 0"
     2185    #bind $frame <KeyPress-End> "$CIF(cattree) yview moveto end"
     2186    # -- does not work
     2187    bind $frame <KeyPress-End> "$CIF(cattree) yview scroll 99999999 page"
     2188    $CIF(cattree) see 0
     2189
     2190    # Bwidget seems to have problems with the name "1", so avoid it
     2191    set num 100
     2192    set n 0
     2193    global catCIFindex
     2194    catch {unset catCIFindex}
     2195    set normalfont [option get [winfo toplevel $CIF(cattree)] font Canvas]
     2196    set italic "$font italic"
     2197    foreach cat [lsort [array names catlist]] {
     2198        if {$cat == ""} continue
     2199        $CIF(cattree) insert end root cat$n -text $cat \
     2200                -open 0 -image [Bitmap::get folder]
     2201        foreach item [lsort $catlist($cat)] {
     2202            set loop [lindex [lindex $CIF_dataname_index($item) 1] 6]
     2203            if {$loop || !$CIF(catselectmode)} {
     2204                set font $normalfont
     2205                set sel 1
     2206            } else {
     2207                set font $italic
     2208                set sel 0
     2209            }
     2210            $CIF(cattree) insert end cat$n [incr num] -text $item \
     2211                    -image [Bitmap::get file] -selectable $sel -font $font
     2212            set catCIFindex($item) $num
     2213        }
     2214        incr n
     2215    }
     2216    # set code to respond to mouse clicks
     2217    $CIF(cattree) bindImage <1> selectCat
     2218    $CIF(cattree) bindText <1>  selectCat
     2219    $CIF(cattree) bindImage <Control-1> {}
     2220    $CIF(cattree) bindText <Control-1>  {}
     2221   
     2222    set CIF(SelCat) {}
     2223    set CIF(CatSelList) {}
     2224    set CIF(CatSelItems) {}
     2225    donewait
     2226    wm deiconify $frame
     2227    tkwait variable CIF(CatSelectDone)
     2228    wm withdraw $frame
     2229}
     2230
     2231# respond to a selection event in CatBrowserWindow
     2232proc selectCat {item} {
     2233    global CIF
     2234    # ignore selected category items
     2235    if {[string first cat $item] == 0} {return}
     2236    set name [$CIF(cattree) itemcget $item -text]
     2237    set category [$CIF(cattree) itemcget [$CIF(cattree) parent $item] -text]
     2238    if {!$CIF(catselectmode)} {
     2239        # single selection mode
     2240        set CIF(SelCat) $category
     2241        set CIF(CatSelList) $item
     2242    } elseif {$CIF(SelCat) != $category} {
     2243        # new category
     2244        set CIF(SelCat) $category
     2245        set CIF(CatSelList) $item
     2246    } elseif {[set ind [lsearch $CIF(CatSelList) $item]] >= 0} {
     2247        # toggle
     2248        set CIF(CatSelList) [lreplace $CIF(CatSelList) $ind $ind]
     2249    } else {
     2250        # add to category
     2251        lappend CIF(CatSelList) $item
     2252    }
     2253    if {[llength $CIF(CatSelList)] == 0} {
     2254        $CIF(cattree) selection clear
     2255    } else {
     2256        eval $CIF(cattree) selection set $CIF(CatSelList)
     2257    }
     2258    set CIF(CatSelItems) {}
     2259    foreach node $CIF(CatSelList) {
     2260        lappend CIF(CatSelItems) [$CIF(cattree) itemcget $node -text]
     2261    }
     2262    if {$CIF(CatSelItems) != ""} {
     2263        ShowDictionaryDefinition $CIF(CatSelItems)
     2264        $CIF(usebutton) configure -state normal
     2265    } else {
     2266        $CIF(usebutton) configure -state disabled
     2267    }
     2268}
     2269
     2270# search through the category browser for a string
     2271proc CatLookupName {} {
     2272    global CIF catCIFindex
     2273    pleasewait "performing search" "" [winfo toplevel $CIF(cattree)]
     2274
     2275    set str $CIF(searchtext)
     2276    # close all nodes
     2277    foreach node [$CIF(cattree) nodes root] {
     2278        $CIF(cattree) closetree $node
     2279    }
     2280    set catsearchlist {}
     2281    set namelist [array names catCIFindex *[string tolower $str]*]
     2282    if {[llength $namelist] == 0} {
     2283        MyMessageBox -parent [winfo toplevel $CIF(cattree)] \
     2284                -title "Not found" \
     2285                -message "String not found" -icon warning -type OK \
     2286                -default ok
     2287    }
     2288    foreach name $namelist {
     2289        set node $catCIFindex($name)
     2290        lappend catsearchlist $node
     2291        set pnode [$CIF(cattree) parent $node]
     2292        $CIF(cattree) opentree $pnode
     2293    }
     2294    set CIF(catsearchlist) [lsort -integer $catsearchlist]
     2295    set CIF(catsearchnum) -1
     2296    donewait
     2297    # find 1st element
     2298    ShowNextcatSearch
     2299}
     2300
     2301# successively display located data items in the category browser
     2302proc ShowNextcatSearch {} {
     2303    global CIF
     2304    $CIF(usebutton) configure -state disabled
     2305    set node [lindex $CIF(catsearchlist) [incr CIF(catsearchnum)]]
     2306    if {$node == ""} {
     2307        set CIF(catsearchnum) 0
     2308        set node [lindex $CIF(catsearchlist) 0]
     2309    }
     2310    if {$node == ""} {
     2311        $CIF(cattree) selection set
     2312        return
     2313    }
     2314    ShowDictionaryDefinition [$CIF(cattree) itemcget $node -text]
     2315    $CIF(cattree) see $node
     2316    $CIF(cattree) selection set $node
     2317}
     2318
     2319# create a data item browser to select a single CIF item
     2320#
     2321proc CatListWindow {parent} {
     2322    global CIF CIF_dataname_index
     2323    global catlist
     2324    set CIF(searchtext) ""
     2325    set frame $parent.catselect
     2326    catch {destroy $frame}
     2327    toplevel $frame
     2328    wm title $frame "CIF Data Name Browser"
     2329    grid [label $frame.top -text "Select a CIF data name to add" \
     2330            -bd 2 -bg beige -relief raised] \
     2331            -sticky news -column 0 -row 0  -columnspan 3
     2332    grid [label $frame.top1 -text "Dictionary" -bg beige -anchor w] \
     2333            -sticky news -column 0 -row 1  -columnspan 2
     2334    grid [label $frame.top2 -text "Data name" -bg beige -anchor w] \
     2335            -sticky news -column 2 -row 1
     2336    grid [frame $frame.bot] -sticky news -column 0 -row 3 -columnspan 3
     2337    grid [label $frame.bot.txt -text "Enter search text:"] \
     2338            -column 0 -row 1
     2339    grid [entry $frame.bot.e -textvariable CIF(searchtext)] \
     2340            -column 1 -row 1
     2341    bind $frame.bot.e <Return> CatFindMatchingNames
     2342    grid [button $frame.bot.src -text "Search" \
     2343            -command CatFindMatchingNames] -column 2 -row 1
     2344    grid [checkbutton $frame.bot.sort -text "Sort by dict." \
     2345            -variable CIF(sortbydict) \
     2346            -command CatFindMatchingNames] -column 3 -row 1
     2347    grid [set CIF(usebutton) [button $frame.bot.use -text "Insert" \
     2348            -command "destroy $frame"]] -column 4 -row 1
     2349    grid [button $frame.bot.q -text Quit \
     2350            -command "set CIF(CatSelItems) {}; destroy $frame"] -column 5 -row 1
     2351    grid [set CIF(catlist) [listbox $frame.list -width 55 \
     2352            -height 20 -exportselection 0 \
     2353            -yscrollcommand "syncLists $frame.list $frame.dict $frame.ys yview"\
     2354            ]] -column 2 -row 2 -sticky nsew
     2355    grid [set CIF(dictlist) [listbox $frame.dict -width 12 \
     2356            -height 20 -exportselection 0 \
     2357            -yscrollcommand "syncLists $frame.dict $frame.list $frame.ys yview"\
     2358            ]] -column 0 -row 2 -sticky nsew
     2359    grid [scrollbar $frame.ys -width 15 -bd 2 \
     2360            -command "moveLists \[list $frame.list $frame.dict] yview" \
     2361            ] -column 1 -row 2  -sticky ns
     2362
     2363    bind $CIF(catlist) <<ListboxSelect>> \
     2364            "ListSelectedCmd $CIF(catlist) $CIF(dictlist); SetSelectedCmd $CIF(catlist)"
     2365    bind $CIF(dictlist) <<ListboxSelect>> \
     2366            "ListSelectedCmd $CIF(dictlist) $CIF(catlist); SetSelectedCmd $CIF(catlist)"
     2367    grid columnconfigure $frame 2 -minsize 275 -weight 1
     2368    grid rowconfigure $frame 2 -weight 1
     2369   
     2370    bind $frame <KeyPress-Prior> "$CIF(catlist) yview scroll -1 page"
     2371    bind $frame <KeyPress-Next> "$CIF(catlist) yview scroll 1 page"
     2372    bind $frame <KeyPress-Up> "$CIF(catlist) yview scroll -1 unit"
     2373    bind $frame <KeyPress-Down> "$CIF(catlist) yview scroll 1 unit"
     2374    bind $frame <KeyPress-Home> "$CIF(catlist) yview moveto 0"
     2375    bind $frame <KeyPress-End> "$CIF(catlist) yview moveto end"
     2376    $CIF(catlist) see 0
     2377
     2378    CatFindMatchingNames
     2379    tkwait window $frame
     2380}
     2381
     2382#
     2383# populate the data item browser created in CatListWindow
     2384proc CatFindMatchingNames {} {
     2385    global CIF CIF_dataname_index
     2386    set str $CIF(searchtext)
     2387    set searchlist {}
     2388    foreach name [array names CIF_dataname_index *[string tolower $str]*] {
     2389        lappend searchlist [list $name [lindex [lindex $CIF_dataname_index($name) 0] 0]]
     2390    }
     2391    $CIF(catlist) delete 0 end
     2392    $CIF(dictlist) delete 0 end
     2393    set searchlist [lsort -index 0 $searchlist]
     2394    if {$CIF(sortbydict)} {set searchlist [lsort -index 1 $searchlist]}
     2395    foreach item $searchlist {
     2396        foreach {name dict} $item {}
     2397        $CIF(catlist) insert end $name
     2398        $CIF(dictlist) insert end $dict
     2399    }
     2400    $CIF(usebutton) configure -state disabled
     2401}
     2402
     2403# replicate selection between list boxes
     2404# list must be config'ed -exportselection 0
     2405proc ListSelectedCmd {master slaves} {
     2406    global CIF
     2407    foreach slave $slaves {
     2408        $slave selection clear 0 end
     2409        $slave selection set [$master curselection]
     2410    }
     2411    $CIF(usebutton) configure -state normal
     2412}
     2413
     2414proc SetSelectedCmd {itemlist} {
     2415    global CIF
     2416    set CIF(CatSelItems) [$itemlist get [$itemlist curselection]]
     2417    ShowDictionaryDefinition $CIF(CatSelItems)
     2418}
     2419
     2420# sync one or more slaved listboxes to a master
     2421# cmd is xview or yview
     2422proc syncLists {master slaves scroll cmd args} {
     2423    foreach slave $slaves {
     2424        $slave $cmd moveto [lindex [$master $cmd] 0]
     2425    }
     2426    eval $scroll set $args
     2427}
     2428
     2429# move multiple listboxes based on a single scrollbar
     2430# cmd is xview or yview
     2431proc moveLists {listlist cmd args} {
     2432    foreach list $listlist {
     2433        eval $list $cmd $args
     2434    }
     2435}
     2436
     2437# insert a data item into block $blk
     2438proc InsertDataItem {dataname blk "value ?"} {
     2439    global CIF
     2440    global $blk
     2441
     2442    # find the last data item in the CIF
     2443    set txt $CIF(txt)
     2444    set last [set ${blk}(lastmark)]
     2445    set i [$txt index $last.r]
     2446    # insert the new dataname right after the last data item
     2447    $txt config -state normal
     2448    $txt insert $i "\n$dataname        " x $value y
     2449    # reposition the mark for the original last data item in case it moved
     2450    $txt mark set $last.r $i
     2451    $txt mark gravity $last.r right
     2452    # convert the tags around $value to marks
     2453    foreach {pos epos} [$txt tag range y] {}
     2454    $txt tag delete x y
     2455    incr CIF(markcount)
     2456    $txt mark set $CIF(markcount).l $pos
     2457    $txt mark set $CIF(markcount).r $epos
     2458    $txt mark gravity $CIF(markcount).l left
     2459    $txt mark gravity $CIF(markcount).r right
     2460    $txt config -state disabled
     2461    set ${blk}($dataname) $CIF(markcount)
     2462    # this is now the last data item in block
     2463    set ${blk}(lastmark)  $CIF(markcount)
     2464    # show the data item in the CIF text
     2465    $txt see $CIF(markcount).r
     2466    # add & show the data item in the tree; open for editing
     2467    set num [incr CIF(tree_lastindex)]
     2468    $CIF(tree) insert end $blk $num -text $dataname \
     2469            -image [Bitmap::get file] -data $blk
     2470    $CIF(tree) see $num
     2471    set CIF(editmode) 1
     2472    showCIFbyTreeID $num
     2473    # register this as a change
     2474    incr CIF(changes)
     2475    # can't undo this so clear the undo status
     2476    set CIF(undolist) {}
     2477    set CIF(redolist) {}
     2478}
     2479
     2480# insert a loop into CIF block $blk
     2481proc InsertDataLoop {namelist blk} {
     2482    global CIF CIF_dataname_index
     2483    global $blk
     2484
     2485    # find the last data item in the CIF
     2486    set txt $CIF(txt)
     2487    set last [set ${blk}(lastmark)]
     2488    set i [$txt index $last.r]
     2489    # insert the new dataname right after the last data item
     2490    $txt config -state normal
     2491    # get the last loop number
     2492    regsub -all "loop_" [array names $blk loop*] "" l
     2493    set n [lindex [lsort -integer $l] end]
     2494    incr n
     2495    # insert the loop into the CIF
     2496    $txt insert $i "\nloop_" x
     2497    foreach name $namelist {
     2498        set epos [lindex [$txt tag range x] end]
     2499        $txt tag delete x
     2500        $txt insert $epos "\n   $name" x
     2501        lappend ${blk}(loop_$n) $name
     2502        set ${blk}($name) {}
     2503    }
     2504    set epos [lindex [$txt tag range x] end]
     2505    $txt tag delete x
     2506    $txt insert $epos "\n     " x
     2507    set epos [lindex [$txt tag range x] end]
     2508    $txt tag delete x
     2509    set catlist {}
     2510    # insert a value for each data name
     2511    foreach name $namelist {
     2512        set epos [$txt index "$epos lineend"]
     2513        if {[lindex [split $epos .] 1] > 70} {
     2514            $txt insert $epos "\n     " x
     2515            set epos [lindex [$txt tag range x] end]
     2516            $txt tag delete x
     2517            set epos [$txt index "$epos lineend"]
     2518        }
     2519        $txt insert $epos ? y " " x
     2520        # convert the tags around the "?" to marks
     2521        foreach {pos epos} [$txt tag range y] {}
     2522        $txt tag delete x y
     2523        incr CIF(markcount)
     2524        $txt mark set $CIF(markcount).l $pos
     2525        $txt mark set $CIF(markcount).r $epos
     2526        $txt mark gravity $CIF(markcount).l left
     2527        $txt mark gravity $CIF(markcount).r right
     2528        lappend ${blk}($name) $CIF(markcount)
     2529        # get the category
     2530        set category {}
     2531        catch {
     2532            set category [lindex \
     2533                    [lindex $CIF_dataname_index($name) 1] 5]
     2534        }
     2535        if {$category != "" && [lsearch $catlist $category] == -1} {
     2536            lappend catlist $category
     2537        }
     2538    }
     2539    # this is now the last data item in block
     2540    set ${blk}(lastmark)  $CIF(markcount)
     2541    # reposition the mark for the original last data item in case it moved
     2542    $txt mark set $last.r $i
     2543    $txt mark gravity $last.r right
     2544    $txt config -state disabled
     2545    # show the data item in the CIF text
     2546    $txt see $CIF(markcount).r
     2547    # add & show the data item in the tree; open for editing
     2548    $CIF(tree) insert end $blk ${blk}loop_$n \
     2549            -text "loop_$n ($catlist)" -open 1 \
     2550            -image [Bitmap::get copy] -data "$blk loop"
     2551    # insert a value for each data name
     2552    foreach name $namelist {
     2553        $CIF(tree) insert end ${blk}loop_$n [incr CIF(tree_lastindex)] \
     2554                -text $name \
     2555                -image [Bitmap::get file] -data $blk
     2556    }
     2557    $CIF(tree) see $CIF(tree_lastindex)
     2558    set CIF(editmode) 1
     2559    showCIFbyTreeID ${blk}loop_$n
     2560    # register this as a change
     2561    incr CIF(changes)
     2562    # can't undo this so clear the undo status
     2563    set CIF(undolist) {}
     2564    set CIF(redolist) {}
     2565}
     2566
     2567# add an item to a CIF
     2568proc AddDataItem2CIF {mode parent} {
     2569    global CIF
     2570    if {[llength $CIF(blocklist)] == 1} {
     2571        set block block$CIF(blocklist)
     2572    } else {
     2573        # select a block here
     2574        set frame $parent.blksel
     2575        catch {destroy $frame}
     2576        toplevel $frame
     2577        wm title $frame "Select a block"
     2578        grid [label $frame.top -text "Select the data block where\nitems will be added" \
     2579            -bd 2 -bg beige -relief raised] \
     2580            -sticky news -column 0 -row 0  -columnspan 3
     2581        grid [listbox $frame.list -width 30 \
     2582                -height 20 -exportselection 0 \
     2583                -yscrollcommand "$frame.ys set"] -column 0 -row 2 -sticky nsew
     2584        grid [scrollbar $frame.ys -width 15 -bd 2 \
     2585                -command "$frame.list yview"] -column 1 -row 2  -sticky ns
     2586        grid [frame $frame.bot] -sticky news -column 0 -row 3 -columnspan 3
     2587        grid [button $frame.bot.use -text Use -state disabled \
     2588            -command "destroy $frame"] -column 4 -row 1
     2589        grid [button $frame.bot.q -text Quit \
     2590                -command "set CIF(selectedBlock) {}; destroy $frame"\
     2591                ] -column 5 -row 1
     2592        foreach n $CIF(blocklist) {
     2593            global block${n}
     2594            set blockname [set block${n}(data_)]
     2595            $frame.list insert end "($n) $blockname"
     2596        }
     2597        bind $frame.list <<ListboxSelect>> \
     2598            "BlockSelectedCmd $frame.list $frame.bot.use"
     2599        bind $frame.list <Double-1> "destroy $frame"
     2600        putontop $frame
     2601        tkwait window $frame
     2602        afterputontop
     2603        if {$CIF(selectedBlock) == ""} return
     2604        set block block$CIF(selectedBlock)
     2605    }
     2606    if {$mode == "loop"} {
     2607        # open a browser window
     2608        CatBrowserWindow $parent
     2609        if {$CIF(CatSelItems) == ""} return
     2610        InsertDataLoop $CIF(CatSelItems) $block
     2611    } elseif {$mode == "category"} {
     2612        # open a browser window to select a single data item
     2613        CatBrowserWindow $parent single
     2614        if {[llength $CIF(CatSelItems)] != 1} return
     2615        InsertDataItem $CIF(CatSelItems) $block
     2616    } else {
     2617        CatListWindow $parent
     2618        if {[llength $CIF(CatSelItems)] != 1} return
     2619        InsertDataItem $CIF(CatSelItems) $block
     2620    }
     2621}
     2622
     2623# respond to selection of a block, when needed
     2624proc BlockSelectedCmd {listbox usebutton} {
     2625    global CIF
     2626    set selected [$listbox curselection]
     2627    if {[llength $selected] == 1} {
     2628        $usebutton configure -state normal
     2629        set CIF(selectedBlock) [lindex [split [$listbox get $selected] "()"] 1]
     2630    } else {
     2631        $usebutton configure -state disabled
     2632        set CIF(selectedBlock) {}
     2633    }
     2634}
     2635#----------------------------------------------------------------------
     2636#----------------------------------------------------------------------
     2637# index and manage dictionaries
     2638#----------------------------------------------------------------------
     2639
     2640# parse a CIF dictionary & save pertinent bits (more for DDL1 than DDL2)
     2641proc MakeCIFdictIndex {f message} {
     2642    global CIF
     2643    set top1 .mkDictIndexTop
     2644    set stat .mkDictIndexStat
     2645    # create an invisible window for parsing a dictionary
     2646    catch {destroy $top1}
     2647    toplevel $top1
     2648    set txt $top1.t
     2649    grid [text $txt -width 80 -yscrollcommand "$top1.s set"] -column 0 -row 0
     2650    grid [scrollbar $top1.s -command "$txt yview"] -column 1 -row 0 -sticky ns
     2651    wm withdraw $top1
     2652    # create a status window
     2653    catch {destroy $stat}
     2654    toplevel $stat
     2655    wm title $stat "Dictionary Parse Status"
     2656    if {$message != ""} {
     2657        grid [label $stat.l0 -text $message] -column 0 -columnspan 2 -row 0
     2658    }
     2659    grid [label $stat.l1 -text "Definitions Processed"] -column 0 -row 1
     2660    grid [label $stat.l2 -textvariable parsestatus] -column 1 -row 1
     2661    putontop $stat 1
     2662    update
     2663
     2664    set counter 0
     2665
     2666    set file [file tail $f]
     2667    global parsestatus
     2668    set parsestatus "$counter (reading $file)"
     2669    update
     2670
     2671    if {[catch {
     2672        set inp [open $f r]
     2673        fconfigure $inp -translation binary
     2674    } errmsg]} {
     2675        catch {close $inp}
     2676        destroy $stat $top1
     2677        return [list 1 $errmsg]
     2678    }
     2679
     2680    # input file is open, can we write to the index?
     2681    set errorstat 0
     2682    if {[catch {
     2683        set fp [open ${f}_index w]
     2684        puts $fp "set CIF_file_name [list $file]"
     2685        puts $fp "set CIF_file_size [file size $f]"
     2686        puts $fp "set CIF_index_version $CIF(indexversion)"
     2687    } errmsg]} {
     2688        set errorstat 2
     2689        catch {close $fp}
     2690        catch {file delete -force ${f}_index}
     2691        set ::CIF_file_paths($file) $f
     2692    }
     2693   
     2694    set text [read $inp]
     2695    close $inp
     2696    # is this a DDL2 dictionary (with save frames)?
     2697    if {[string match -nocase "*save_*" $text]} {
     2698        set DDL2 1
     2699        regsub -all "save__" $text "data__" text
     2700        regsub -all "save_" $text "####_" text
     2701    } else {
     2702        set DDL2 0
     2703    }
     2704    $txt insert end $text
     2705    # free up some memory
     2706    unset text
     2707
     2708    set parsestatus "$counter (starting parse)"
     2709    update
     2710
     2711
     2712    set blocks [ParseCIF $txt {} CIFdict]
     2713    set allblocks {}
     2714    set prevpos 1.0
     2715    set prevbytes 0
     2716    set parsestatus "$counter (parse complete)"
     2717    update
     2718
     2719    if {$errorstat == 0} {
     2720        puts $fp "set CIF_file_mtime [file mtime $f]"
     2721        puts $fp "array set CIF_dataname_index \{"
     2722    }
     2723    set definednames {}
     2724    for {set i 1} {$i <= $blocks} {incr i} {
     2725        incr counter
     2726        if {$counter % 10 == 0} {
     2727            set parsestatus $counter
     2728            update
     2729        }
     2730        lappend allblocks $i
     2731        if {![catch {set CIFdict::block${i}(errors)}]} {
     2732            puts stderr "Block $i ([set CIFdict::block${i}(data_)]) errors:"
     2733            puts stderr "[set CIFdict::block${i}(errors)]"
     2734        }
     2735        # list of positions for dataname
     2736        set list {}
     2737        catch {set list [set CIFdict::block${i}(_name)]}
     2738        if {$list == "" && $DDL2} {
     2739            catch {set list [set CIFdict::block${i}(_item.name)]}
     2740        }
     2741        # definition entry
     2742        set def {}
     2743        catch {set def  [set CIFdict::block${i}(_definition)]}
     2744        if {$def == "" && $DDL2} {
     2745            catch {set def  [set CIFdict::block${i}(_item_description.description)]}
     2746        }
     2747        if {$def == ""} continue
     2748        if {[llength $def] != 1} {puts stderr "problem with [set CIFdict::block${i}(data_)]"}
     2749        # count the number of bytes from the previous position
     2750        # (much faster than counting from the beginning each time)
     2751        #set defpos [string length [$txt get 1.0 $def.l]]
     2752        set defpos [string length [$txt get $prevpos $def.l]]
     2753        incr defpos $prevbytes
     2754        set prevpos $def.l
     2755        set prevbytes $defpos
     2756        set deflen [string length [$txt get $def.l $def.r]]
     2757        # item type (numb/char/null)
     2758        set type {}
     2759        catch {set type [set CIFdict::block${i}(_type)]}
     2760        if {$type == "" && $DDL2} {
     2761            catch {set type [set CIFdict::block${i}(_item_type.code)]}
     2762            if {[llength $type] != 1} {
     2763                set typeval "?"
     2764            } else {
     2765                set typeval [StripQuotes [$txt get $type.l $type.r]]
     2766            }
     2767            # mmCIF uses: atcode, code, float, int, line, symop, text
     2768            #             uchar1, uchar3, ucode, uline, yyyy-mm-dd
     2769            # treat everything but float & int as character
     2770            if {$typeval == "float" || $typeval == "int"} {
     2771                set typeval "n"
     2772            } else {
     2773                set typeval "c"
     2774            }
     2775        } elseif {[llength $type] != 1} {
     2776            puts stderr "type problem for [set CIFdict::block${i}(data_)]"
     2777            set typeval "?"
     2778        } else {
     2779            set typeval [StripQuotes [$txt get $type.l $type.r]]
     2780            if {$typeval == "numb"} {
     2781                set typeval "n"
     2782            } elseif {$typeval == "char"} {
     2783                set typeval "c"
     2784            } elseif {$typeval == "null"} {
     2785                set typeval ""
     2786            } else {
     2787                puts stderr "Block [set CIFdict::block${i}(data_)] has invalid _type ($typeval)"
     2788                set typeval "?"
     2789            }
     2790        }
     2791        # flag if esd's are allowed
     2792        set pos {}
     2793        catch {set pos [set CIFdict::block${i}(_type_conditions)]}
     2794        if {$pos == "" && $DDL2} {
     2795            catch {set pos [set CIFdict::block${i}(_item_type_conditions.code)]}
     2796        }
     2797        if {[llength $pos] != 1} {
     2798            set esd 0
     2799        } else {
     2800            if {"esd" == [string tolower \
     2801                    [StripQuotes [$txt get $pos.l $pos.r]]]} {set esd 1}
     2802        }
     2803        # units (_units_details overrides _units)
     2804        set pos {}
     2805        catch {set pos [set CIFdict::block${i}(_units)]}
     2806        if {$pos == "" && $DDL2} {
     2807            catch {set pos [set CIFdict::block${i}(_item_units.code)]}
     2808        } else {
     2809            catch {set pos [set CIFdict::block${i}(_units_details)]}
     2810        }
     2811        if {[llength $pos] != 1} {
     2812            set units {}
     2813        } else {
     2814            set units [StripQuotes [$txt get $pos.l $pos.r]]
     2815        }
     2816        # parse out _enumeration _enumeration_detail & _enumeration_range
     2817        set elist ""
     2818        set enumlist {}
     2819        set enumdetaillist {}
     2820        if {$DDL2} {
     2821            catch {
     2822                set enumlist [set CIFdict::block${i}(_item_enumeration.value)]
     2823                set enumdetaillist [set CIFdict::block${i}(_item_enumeration.detail)]
     2824            }
     2825        } else {
     2826            catch {
     2827                set enumlist [set CIFdict::block${i}(_enumeration)]
     2828                set enumdetaillist [set CIFdict::block${i}(_enumeration_detail)]
     2829            }
     2830        }
     2831        catch {
     2832            foreach m1 $enumlist \
     2833                    m2 $enumdetaillist {
     2834                if {$m2 != ""} {
     2835                    set detail [StripQuotes [$txt get $m2.l $m2.r]]]
     2836                    # condense multiple spaces out
     2837                    regsub -all {  +} $detail { } detail
     2838                } else {
     2839                    set detail {}
     2840                }
     2841                lappend elist [list [StripQuotes [$txt get $m1.l $m1.r]] $detail]
     2842            }
     2843        }
     2844        # mmCIF ranges are too complex to do here
     2845        set range ""
     2846        catch {
     2847            set mark [set CIFdict::block${i}(_enumeration_range)]
     2848            lappend range [StripQuotes [$txt get $mark.l $mark.r]]
     2849        }
     2850
     2851        # category names
     2852        set pos ""
     2853        catch {set pos [set CIFdict::block${i}(_category)]}
     2854        if {$pos == "" && $DDL2} {
     2855            catch {set pos [set CIFdict::block${i}(_item.category_id)]}
     2856        }
     2857        if {[llength $pos] != 1} {
     2858            set category {}
     2859        } else {
     2860            set category [StripQuotes [$txt get $pos.l $pos.r]]
     2861        }
     2862        # loop is 1 if loops are allowed
     2863        if {$DDL2} {
     2864            # at least for now, don't worry about DDL2 dictionaries
     2865            set loop 1
     2866        } else {
     2867            set loop 0
     2868            catch {
     2869                set pos [set CIFdict::block${i}(_list)]
     2870                set val [string tolower [StripQuotes [$txt get $pos.l $pos.r]]]
     2871                if {$val == "yes" || $val == "both"} {set loop 1}
     2872            }
     2873        }
     2874        foreach mark $list {
     2875            set dataname [string tolower [StripQuotes [$txt get $mark.l $mark.r]]]
     2876            lappend definednames $dataname
     2877            # note that this list must match foreach "type range elist... uses
     2878            set value   [list [list $file $defpos $deflen] \
     2879                        [list $typeval $range $elist $esd $units $category $loop]]
     2880            if {$errorstat == 0} {
     2881                puts $fp "\t$dataname \t[list $value]"
     2882            } else {
     2883                set ::CIF_dataname_index($dataname) $value
     2884            }
     2885        }
     2886    }
     2887    set parsestatus "$counter (close file)"
     2888    update
     2889
     2890    if {$errorstat == 0} {
     2891        puts $fp "\}"
     2892        puts $fp "set definednames \{"
     2893        foreach name [lsort $definednames] {
     2894            puts $fp "\t[list $name]"
     2895        }
     2896        puts $fp "\}"
     2897    }
     2898    catch {close $fp}
     2899    afterputontop
     2900    destroy $top1
     2901    destroy $stat
     2902    namespace delete CIFdict
     2903    if {$errorstat == 0} {
     2904        return {}
     2905    } else {
     2906        return [list $errorstat $errmsg]
     2907    }
     2908}
     2909
     2910# load indices to the dictionaries in CIF(dictfilelist), unless
     2911# the variable does not exist or is empty
     2912proc LoadDictIndices {} {
     2913    global scriptdir CIF CIF_file_paths
     2914    global CIF_dataname_index
     2915    # clear out any previous dictionary entries
     2916    catch {unset CIF_dataname_index}
     2917    # clear out array of file paths
     2918    catch {unset CIF_file_paths}
     2919    # clear out error listings
     2920    set CIF(overloaded) 0
     2921    set CIF(overloadlist) {}
     2922    set CIF(dictwriteerrorlist) {}
     2923    set CIF(dictwriteerrors) {}
     2924    # clear out an old category browser window
     2925    catch {destroy $CIF(CategoryBrowserWin)}
     2926   
     2927    # is there a defined list of dictionary files?
     2928    set flag 0
     2929    if {[catch {set CIF(dictfilelist)}]} {
     2930        set flag 1
     2931    } elseif {[llength $CIF(dictfilelist)] == 0} {
     2932        set flag 1
     2933    }
     2934    # if no files are present in the dictionary list, look
     2935    # in the standard places for them
     2936    if {$flag} {
     2937        # get a list of dictionary files
     2938        #    CIFTOOLS location:
     2939        set dictfilelist [glob -nocomplain [file join $scriptdir dict *.dic]]
     2940        #
     2941        foreach file $dictfilelist {
     2942            lappend CIF(dictfilelist) $file
     2943            set CIF(dict_$file) 1
     2944        }
     2945    }
     2946
     2947    if {[catch {set CIF(dictfilelist)}]} {
     2948        set CIF(dictfilelist) {}
     2949    }
     2950    # load the dictionaries
     2951    foreach file $CIF(dictfilelist) {
     2952        if {!$CIF(dict_$file)} continue
     2953        if {![file exists $file]} continue
     2954        IndexLoadDict $file
     2955    }
     2956    if {[llength $CIF(dictwriteerrorlist)] >0} {
     2957        set msg "Error: unable to writing index files for dictionary:"
     2958        foreach dict $CIF(dictwriteerrorlist) {
     2959            append msg "\n\t[file tail $dict]"
     2960        }
     2961        append msg "\n\nDo you have write permission?"
     2962        set ans [MyMessageBox -parent . -title "CIF index error" \
     2963                -message $msg \
     2964                -icon error -type {Continue "See List"} -default continue]
     2965        if {$ans != "continue"} {
     2966            MyMessageBox -parent . -title "Error(s)" \
     2967                    -message $CIF(dictwriteerrors) \
     2968                    -icon warning -type Continue -default continue
     2969        }
     2970    }
     2971    if {$CIF(overloaded) != 0 && $CIF(ShowDictDups)} {
     2972        set ans [MyMessageBox -parent . -title "Definitions overridden" \
     2973                -message "Loading CIF dictionaries.\nNote: $CIF(overloaded) datanames appeared in more than one dictionary -- only the last reference is used." \
     2974                -icon warning -type {Continue "See List"} -default continue]
     2975        if {$ans != "continue"} {
     2976            MyMessageBox -parent . -title "List of overridden definitions" \
     2977                    -message $CIF(overloadlist) \
     2978                    -icon warning -type Continue -default continue
     2979        }
     2980    }
     2981}
     2982
     2983# load an index to a dictionary file, create the index if needed.
     2984# save the index to CIF dictionary named XXXXX.dic as XXXXX.dic_index
     2985# if the file cannot be written, create an error message and just load
     2986# it anyway.
     2987proc IndexLoadDict {file} {
     2988    global CIF
     2989    global CIF_dataname_index CIF_file_paths
     2990    # save the array contents
     2991    set orignamelist [array names CIF_dataname_index]
     2992
     2993    set flag 0
     2994    if {![file exists ${file}_index]} {
     2995        set flag 1
     2996    } elseif {[file mtime $file] > [file mtime ${file}_index]} {
     2997        set flag 1
     2998    }
     2999    if {$flag} {
     3000        set stat [MakeCIFdictIndex $file "Please wait, indexing file $file"]
     3001        if {[lindex $stat 0] != ""} {
     3002            lappend CIF(dictwriteerrorlist) $file
     3003            append CIF(dictwriteerrors) "=================================\n"
     3004            append CIF(dictwriteerrors) "Error indexing file $file:\n"
     3005            append CIF(dictwriteerrors) "=================================\n"
     3006            append CIF(dictwriteerrors) [lindex $stat 1]
     3007            append CIF(dictwriteerrors) "\n\n"
     3008            return 1
     3009        }
     3010    }
     3011
     3012    set CIF_index_version 0
     3013    set redo 0
     3014    if {[catch {
     3015        source ${file}_index
     3016    } errmsg]} {
     3017        set stat [MakeCIFdictIndex $file \
     3018                "Please wait, reindexing $file, Error reading file index."]
     3019#       MyMessageBox -parent . -title "CIF index error" \
     3020#               -message "Error reading file ${file}_index -- this should not happen:\n$errmsg" \
     3021#               -icon error -type {"Oh darn"} -default "oh darn"
     3022        set redo 1
     3023    }
     3024    if {$CIF_index_version < $CIF(indexversion)} {
     3025        set redo 1
     3026        set stat [MakeCIFdictIndex $file \
     3027                "Please wait, reindexing $file, index is out of date."]
     3028    } elseif {[file size $file] != $CIF_file_size} {
     3029        set redo 1
     3030        set stat [MakeCIFdictIndex $file \
     3031                "Please wait, reindexing $file, file size has changed"]
     3032    }
     3033    if {$redo} {
     3034        if {[lindex $stat 0] != ""} {
     3035            lappend CIF(dictwriteerrorlist) $file
     3036            append CIF(dictwriteerrors) "=================================\n"
     3037            append CIF(dictwriteerrors) "Error indexing file $file:\n"
     3038            append CIF(dictwriteerrors) "=================================\n"
     3039            append CIF(dictwriteerrors) [lindex $stat 1]
     3040            append CIF(dictwriteerrors) "\n\n"
     3041            return 1
     3042        }
     3043        if {[catch {
     3044            source ${file}_index
     3045        } errmsg]} {
     3046            MyMessageBox -parent . -title "CIF index error" \
     3047                    -message "Error reading file ${file}_index -- this should not happen:\n$errmsg" \
     3048                    -icon error -type {"Oh darn"} -default "oh darn"
     3049            return 1
     3050        }
     3051    }
     3052    if {[array names CIF_file_paths $CIF_file_name] != ""} {
     3053        MyMessageBox -parent . -title "Duplicate dictionary name" \
     3054                -message "Note: you are using two dictionaries with the same name ($CIF_file_name). The locations are:\n$CIF_file_paths($CIF_file_name)\n$file\n\nOnly the latter file will be accessed." \
     3055                -icon warning -type {"Oh well"} -default "oh well"
     3056    }
     3057    set CIF_file_paths($CIF_file_name) $file
     3058    # now check for overridden names
     3059    set errorlist {}
     3060    foreach name $definednames {
     3061        if {[lsearch -exact $orignamelist $name] != -1} {
     3062            incr CIF(overloaded)
     3063            append errorlist "\t$name\n"
     3064        }
     3065    }
     3066    if {$errorlist != ""} {
     3067        append CIF(overloadlist) "\ndictionary $file overrides definitions for datanames:\n" $errorlist
     3068    }
     3069    return
     3070}
     3071
     3072# make a window for selecting dictionaries
     3073proc MakeDictSelect {parent} {
     3074    global CIF
     3075    global CIF_dataname_index
     3076    #global icon
     3077    set icon(up) [image create bitmap -data {
     3078        #define up_width 24
     3079        #define up_height 24
     3080        static unsigned char up_bits[] = {
     3081            0x00, 0x18, 0x00, 0x00, 0x18, 0x00,
     3082            0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00,
     3083            0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00,
     3084            0x00, 0xff, 0x00, 0x00, 0xff, 0x00,
     3085            0x80, 0xff, 0x01, 0x80, 0xff, 0x01,
     3086            0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03,
     3087            0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07,
     3088            0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f,
     3089            0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f,
     3090            0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f,
     3091            0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f,
     3092            0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
     3093    }]
     3094
     3095    set icon(down) [image create bitmap -data {
     3096        #define down_width 24
     3097        #define down_height 24
     3098        static unsigned char down_bits[] = {
     3099            0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
     3100            0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f,
     3101            0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f,
     3102            0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f,
     3103            0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f,
     3104            0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07,
     3105            0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03,
     3106            0x80, 0xff, 0x01, 0x80, 0xff, 0x01,
     3107            0x00, 0xff, 0x00, 0x00, 0xff, 0x00,
     3108            0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00,
     3109            0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00,
     3110            0x00, 0x18, 0x00, 0x00, 0x18, 0x00};
     3111    }]
     3112
     3113    set win $parent.dictselect
     3114    catch {destroy $win}
     3115    toplevel $win
     3116    wm title $win "Select CIF dictionaries"
     3117    grid [canvas $win.canvas \
     3118            -scrollregion {0 0 5000 500} -width 0 -height 200 \
     3119            -xscrollcommand "$win.xscroll set" \
     3120            -yscrollcommand "$win.scroll set"] \
     3121            -column 0 -row 2 -sticky nsew
     3122    grid columnconfigure $win 0 -weight 1
     3123    grid rowconfigure $win 2 -weight 1
     3124    scrollbar $win.scroll \
     3125            -command "$win.canvas yview"
     3126    scrollbar $win.xscroll -orient horizontal \
     3127            -command "$win.canvas xview"
     3128    frame [set CIF(dictlistbox) $win.canvas.fr]
     3129    $win.canvas create window 0 0 -anchor nw -window $CIF(dictlistbox)
     3130    grid [label $win.top -text "Select dictionaries to be loaded" -bg beige] \
     3131            -column 0 -columnspan 99 -row 0 -sticky ew
     3132    grid [label $win.top1 \
     3133            -text "(Dictionaries are loaded in the order listed)" -bg beige] \
     3134            -column 0 -columnspan 99 -row 1 -sticky ew
     3135    catch {$win.top1 config -font "[$win.top1 cget -font] italic"}
     3136    grid [frame  $win.bot] \
     3137            -column 0 -columnspan 99 -row 99 -sticky ew
     3138    set col 0
     3139    grid [button $win.bot.add -text "Add Dictionary" \
     3140            -command "OpenLoadDict $win"] \
     3141            -column $col -row 0
     3142    grid [button $win.bot.save -text "Save current settings" \
     3143            -command "SaveOptions"] \
     3144            -column [incr col] -row 0
     3145    grid [button $win.bot.up -image $icon(up) -width 35\
     3146            -command ShiftDictUp] \
     3147            -column [incr col] -row 0
     3148    grid [button $win.bot.down -image $icon(down) -width 35 \
     3149            -command ShiftDictDown] \
     3150            -column [incr col] -row 0
     3151
     3152    grid [button $win.bot.cancel -text Close -command "destroy $win; LoadDictIndices"] \
     3153            -column [incr col] -row 0
     3154    wm protocol $win WM_DELETE_WINDOW "$win.bot.cancel invoke"
     3155
     3156    FillDictSelect
     3157
     3158    update
     3159    #putontop $win
     3160    #tkwait window $win
     3161    #afterputontop
     3162}
     3163
     3164
     3165# respond to a dictionary selection
     3166proc SelectDict {row} {
     3167    global CIF
     3168    set widget $CIF(dictlistbox)
     3169    if {$CIF(selected_dict) != ""} {
     3170        ${widget}.c$CIF(selected_dict) config -bg \
     3171                [option get [winfo toplevel $widget] background Frame]
     3172    }
     3173    set CIF(selected_dict) $row
     3174    ${widget}.c$row config -bg black
     3175}
     3176
     3177# shift the selected dictionary up in the list
     3178proc ShiftDictUp {} {
     3179    global CIF
     3180    if {$CIF(selected_dict) == ""} {
     3181        bell
     3182        return
     3183    }
     3184    if {$CIF(selected_dict) == 0} {
     3185        return
     3186    }
     3187    set prev [set pos $CIF(selected_dict)]
     3188    incr prev -1
     3189    set CIF(dictfilelist) [lreplace $CIF(dictfilelist) $prev $pos \
     3190            [lindex $CIF(dictfilelist) $pos] \
     3191            [lindex $CIF(dictfilelist) $prev]]
     3192    FillDictSelect
     3193    SelectDict $prev
     3194}
     3195
     3196# shift the selected dictionary down in the list
     3197proc ShiftDictDown {} {
     3198    global CIF
     3199    if {$CIF(selected_dict) == ""} {
     3200        bell
     3201        return
     3202    }
     3203    if {$CIF(selected_dict) == [llength  $CIF(dictfilelist)]-1} {
     3204        return
     3205    }
     3206    set next [set pos $CIF(selected_dict)]
     3207    incr next 1
     3208    set CIF(dictfilelist) [lreplace $CIF(dictfilelist) $pos $next \
     3209            [lindex $CIF(dictfilelist) $next] \
     3210            [lindex $CIF(dictfilelist) $pos]]
     3211    FillDictSelect
     3212    SelectDict $next
     3213}
     3214
     3215# place the dictionary list into the window
     3216proc FillDictSelect {} {
     3217    global CIF
     3218
     3219    set win [winfo toplevel $CIF(dictlistbox)]
     3220    eval destroy [winfo children $CIF(dictlistbox)]
     3221    set CIF(dictlistboxRow) -1
     3222    foreach file $CIF(dictfilelist) {
     3223        set lbl $file
     3224        if {![file exists $file]} {
     3225            set lbl "$file (not found)"
     3226            set CIF(dict_$file) 0
     3227        }
     3228        set row [incr CIF(dictlistboxRow)]
     3229        grid [frame $CIF(dictlistbox).c$row -bd 3] -column 0 -row $row -sticky w
     3230        grid [checkbutton $CIF(dictlistbox).c$row.c -text $lbl \
     3231                -command "SelectDict $row" \
     3232                -variable CIF(dict_$file)] \
     3233                -column 0 -row 0 -sticky w
     3234        if {![file exists $file]} {
     3235            $CIF(dictlistbox).c$row.c config -state disabled
     3236        }
     3237    }
     3238    set CIF(selected_dict) {}
     3239    # resize the list
     3240    update
     3241    set sizes [grid bbox $win.canvas.fr]
     3242    $win.canvas config -scrollregion $sizes -width [lindex $sizes 2]
     3243    # use the scroll for BIG lists
     3244    if {[lindex $sizes 3] > [winfo height $win.canvas]} {
     3245        grid $win.scroll -sticky ns -column 1 -row 2
     3246    } else {
     3247        grid forget $win.scroll
     3248    }
     3249    if {[lindex $sizes 2] > [winfo width $win.canvas]} {
     3250        grid $win.xscroll -sticky ew -column 0 -row 3
     3251    } else {
     3252        grid forget $win.xscroll
     3253    }
     3254}
     3255
     3256# open a new dictionary and add it to the list
     3257proc OpenLoadDict {win} {
     3258    global CIF
     3259    set file [tk_getOpenFile -title "Select CIF" -parent $win \
     3260            -defaultextension .dic -filetypes {{"CIF dictionary" ".dic"}}]
     3261    if {$file == ""} {return}
     3262    if {![file exists $file]} {
     3263        MyMessageBox -parent . -title "CIF error" \
     3264                -message "Error file $file does not exist -- this should not happen" \
     3265                -icon error -type {"Oh darn"} -default "oh darn"
     3266    }
     3267    if {[IndexLoadDict $file] == 1} return
     3268    set CIF(dict_$file) 1
     3269    lappend CIF(dictfilelist) $file
     3270
     3271    FillDictSelect
     3272
     3273    $win.canvas xview moveto 0
     3274}
     3275
     3276# a dummy routine -- each program should have its own SaveOptions routine
     3277proc SaveOptions {} {
     3278    MyMessageBox -parent . -title "Not saved" \
     3279            -message "SaveOptions is not implemented in this program" \
     3280            -icon "info" -type OK -default OK
     3281}
     3282
     3283#----------------------------------------------------------------------
    20303284# initialize misc variables
    20313285set CIF(changes) 0
    … …  
    20373291set CIF(redolist) {}
    20383292set CIF(treeSelectedList) {}
     3293set CIF(catsearchnum) -1
     3294set CIF(catsearchlist) {}
     3295# version of the dictionary that is needed by the current program
     3296set CIF(indexversion) 1.1
     3297# make sure this variable is defined
     3298if {[catch {set CIF(ShowDictDups)}]} {set CIF(ShowDictDups) 0}
Note: See TracChangeset for help on using the changeset viewer.