source: trunk/addcmds.tcl @ 152

# $Id: addcmds.tcl 132 2009-12-04 23:00:56Z toby $

proc MakeAddPhaseBox {} {
    global expmap

    set nextphase ""
    foreach p {1 2 3 4 5 6 7 8 9} {
        if {[lsearch $expmap(phaselist) $p] == -1} {
            set nextphase $p
            break
        }
    }

    # no more room
    if {$nextphase == ""} {
        tk_dialog .phaseerr "Add Phase Error" \
                "There are already 9 phases. You cannot add more." \
                error 0 "OK" 
        return
    }

    set np .newphase
    catch {destroy $np}
    toplevel $np

    grid [label $np.l1 -text "Adding phase #$nextphase"] \
            -column 0 -row 0 -sticky w
    grid [label $np.l2 -text "Phase title:"] -column 0 -row 1 
    grid [entry $np.t1 -width 68] -column 1 -row 1 -columnspan 8
    grid [label $np.l3 -text "Space Group:"] -column 0 -row 2 
    grid [entry $np.t2 -width 12] -column 1 -row 2 
    grid [frame $np.f -bd 4 -relief groove] -column 3 -row 2 -columnspan 8
    set col -1
    foreach i {a b c} {
        grid [label $np.f.l1$i -text $i] -column [incr col] -row 1
        grid [entry $np.f.e1$i -width 12] -column [incr col]  -row 1
    }
    set col -1
    foreach i {a b g} {
        grid [label $np.f.l2$i -text $i -font symbol] -column [incr col] -row 2
        grid [entry $np.f.e2$i -width 12] -column [incr col]  -row 2
        $np.f.e2$i insert 0 90.
    }   
    
    grid [button $np.b1 -text Add \
            -command "addphase $np"] -column 2 -row 3
    bind $np <Return> "addphase $np"
    grid [button $np.b2 -text Cancel \
            -command "destroy $np"] -column 3 -row 3
    
    wm title $np "add new phase"

    # grab focus, etc.
    putontop $np

    tkwait window $np

    # fix focus...
    afterputontop
}

proc addphase {np} {
    global expgui
    # validate the input
    set err {}
    set title [$np.t1 get]
    if {[string trim $title] == ""} {
        append err "  Title cannot be blank\n"
    }
    set spg [$np.t2 get]
    if {[string trim $spg] == ""} {
        append err "  Space group cannot be blank\n"
    }
    foreach i {a b c} {
        set cell($i) [$np.f.e1$i get]
        if {[string trim $cell($i)] == ""} {
            append err "  $i cannot be blank\n"
        } elseif {[catch {expr $cell($i)}]} {
            append err "  $i is not valid\n"
        }
    }

    foreach i {a b g} lbl {alpha beta gamma} {
        set cell($lbl) [$np.f.e2$i get]
        if {[string trim $cell($lbl)] == ""} {
            append err "  $lbl cannot be blank\n"
        } elseif {[catch {expr $cell($lbl)}]} {
            append err "  $lbl is not valid\n"
        }
    }

    if {$err != ""} {
        tk_dialog .phaseerr "Add Phase Error" \
                "The following error(s) were found in your input:\n$err" \
                error 0 "OK" 
        return
    }

    # check the space group
    set fp [open spg.in w]
    puts $fp "N"
    puts $fp "N"
    puts $fp $spg
    puts $fp "Q"
    close $fp
    global tcl_platform
    catch {
        if {$tcl_platform(platform) == "windows"} {
            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
        } else {
            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
        }
    }
    set fp [open spg.out r]
    set out [read $fp]
    close $fp
    # attempt to parse out the output (fix up if parse did not work)
    if {[regexp "space group symbol.*>(.*)Enter a new space group symbol" \
            $out a b ] != 1} {set b $out}
    if {[string first Error $b] != -1} {
        # got an error, show it
        ShowBigMessage \
                 $np.error \
                 "Error processing space group\nReview error message below" \
                 $b
        return
    } else {
        # show the result and confirm
        set opt [ShowBigMessage \
                $np.check \
                "Check the symmetry operators in the output below" \
                $b \
                {Continue Redo} ]
        if {$opt > 1} return
    }
    file delete spg.in spg.out
    
    # ok do it!
    set fp [open exptool.in w]
    puts $fp "P"
    puts $fp $title
    puts $fp $spg
    puts $fp "$cell(a) $cell(b) $cell(c) $cell(alpha) $cell(beta) $cell(gamma)"
    puts $fp "/"
    close $fp
    global tcl_platform
    # Save the current exp file
    savearchiveexp
    # disable the file changed monitor
    set expgui(expModifiedLast) 0
    set expnam [file root [file tail $expgui(expfile)]]
    catch {
        if {$tcl_platform(platform) == "windows"} {
            exec [file join $expgui(gsasexe) exptool.exe] $expnam \
                    < exptool.in >& exptool.out
        } else {
            exec [file join $expgui(gsasexe) exptool] $expnam \
                    < exptool.in >& exptool.out
        }
    } errmsg
    # load the revised exp file
    loadexp $expgui(expfile)
    set fp [open exptool.out r]
    set out [read $fp]
    close $fp
    destroy $np
    if {$errmsg != ""} {
        append errmsg "\n" $out
    } else {
        set errmsg $out
    }
    ShowBigMessage \
                 $np \
                 "Please review the result from adding the phase" \
                 $errmsg
    file delete exptool.in exptool.out
}

proc MakeAddHistBox {} {
    global expmap newhist

    # --> should check here if room for another histogram, but only texture
    # folks will ever need that

    set np .newhist
    catch {destroy $np}
    toplevel $np

    grid [label $np.l0 -text "Adding new histogram"] \
            -column 0 -row 0 -sticky ew -columnspan 7
    grid [label $np.l1 -text "Data file:"] -column 0 -row 1 
    grid [label $np.t1 -textvariable newhist(rawfile) -bd 2 -relief ridge] \
            -column 1 -row 1 -columnspan 3 -sticky ew
    grid [button $np.b1 -text "Select File" \
            -command "getrawfile $np" \
            ] -column 4 -row 1

    grid [label $np.lbank -text "Select bank" -anchor w] -column 1 -row 2 -sticky w
    grid [frame $np.bank]  -column 2 -row 2 -columnspan 7 -sticky ew

    grid [label $np.l2 -text "Instrument\nParameter file:"] -column 0 -row 3
    grid [label $np.t2 -textvariable newhist(instfile) -bd 2 -relief ridge] \
            -column 1 -row 3 -columnspan 3 -sticky ew
    grid [button $np.b2 -text "Select File" \
            -command "getinstfile $np" \
            ] -column 4 -row 3

    grid [label $np.lset -text "Select set" -anchor w] -column 1 -row 4 -sticky w
    grid [frame $np.set]  -column 2 -row 4 -columnspan 7 -sticky ew

    grid [label $np.l3 -text "Usable data limit:"] -column 0 -row 5 -rowspan 2 
    grid [entry $np.e3 -width 12 -textvariable newhist(2tLimit) \
            ] -column 1 -row 5 -rowspan 2 
    grid [radiobutton $np.cb3 -text "D-min" -variable newhist(LimitMode) \
            -value 0] -column 2 -row 5 -sticky w
    grid [radiobutton $np.cb4 -text "2-Theta Max" -variable newhist(LimitMode)\
            -value 1] -column 2 -row 6 -sticky w
    
    grid [frame $np.f6] -column 1 -row 7 -columnspan 3
    grid [button $np.f6.b6a -text Add \
            -command "addhist $np"] -column 0 -row 0
    bind $np <Return> "addhist $np"
    grid [button $np.f6.b6b -text Cancel \
            -command "destroy $np"] -column 1 -row 0
    
    grid columnconfigure $np 3 -weight 1

    wm title $np "add new histogram"

    if {[string trim $newhist(rawfile)] != {}} {
        validaterawfile $np $newhist(rawfile)
    }
    if {[string trim $newhist(instfile)] != {}} {
        validateinstfile $np $newhist(instfile)
    }
    set newhist(banknum) {}
    set newhist(setnum) {}
    #    for {set i 0} {$i<100} {incr i} {set newhist(bank$i) 0}
    #    for {set i 0} {$i<100} {incr i} {set newhist(set$i) 0}

    # grab focus, etc.
    putontop $np

    tkwait window $np

    # fix focus...
    afterputontop
}

# convert a file to Win-95 direct access
proc WinCvt {file} {
    global expgui
    if ![file exists $file] {
        tk_dialog .warn "Convert Error" \
                "File $file does not exist" question 0 "OK"
        return
    }

    set tmpname "[file join [file dirname $file] tempfile.xxx]"
    set oldname "[file rootname $file].org"
    if [file exists $oldname] {
        set ans [tk_dialog .warn "OK to overwrite?" \
                "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" question 0 \
                "Yes" "No"]
        if $ans return
        catch {file delete $oldname}
    }

    if [catch {
        set in [open $file r]
        # needed to test under UNIX
        set out [open $tmpname w]
        fconfigure $out -translation crlf
        set len [gets $in line]
        if {$len > 160} {
            # this is a UNIX file. Hope there are no control characters
            set i 0
            set j 79
            while {$j < $len} {
                puts $out [string range $line $i $j]
                incr i 80
                incr j 80
            }
        } else {
            while {$len >= 0} {
                append line "                                        "
                append line "                                        "
                set line [string range $line 0 79]
                puts $out $line
                set len [gets $in line]
            }
        }
        close $in
        close $out
        file rename $file $oldname
        file rename $tmpname $file
    } errmsg] {
        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
    }
    return $file
}

proc getrawfile {np} {
    global newhist tcl_platform
    if {$tcl_platform(platform) == "windows"} {
        set inp [
        tk_getOpenFile -parent $np -initialfile $newhist(rawfile) -filetypes {
            {"Data files" .GSAS} {"Data files" .GSA} 
            {"Data files" .RAW}  {"All files" *}
        }
        ]
    } else {
        set inp [
        tk_getOpenFile -parent $np -initialfile $newhist(rawfile) -filetypes {
            {"Data files" .GSA*} {"Data files" .RAW}  
            {"Data files" .gsa*} {"Data files" .raw}  
            {"All files" *}
        } 
        ]
    }
    validaterawfile $np $inp
}

proc validaterawfile {np inp} {
    global tcl_platform expgui newhist
    if {$inp == ""} return
    if [catch {set in [open $inp r]}] {
        tk_dialog .err "Open error" "Unable to open file $inp" \
                error 0 OK
        return 
    }
    set newhist(banklist) {}
    foreach child [pack slaves $np.bank] {destroy $child}
    # is this a properly formatted file?
    if {$tcl_platform(platform) == "windows"} {
        # are lines the correct length?

        #--> can we check that lines are terminated CR-LF?

        set i 0
        while {[set len [gets $in line]] > 0} {
            incr i
            if {$len != 80} {
                set ans [tk_dialog .err "Read error" \
                        "File $inp is not direct access. OK to convert?" \
                        error 0 OK QUIT]
                if {$ans == 0} {
                    close $in
                    WinCvt $inp
                    set i 0
                    set in [open $inp r]
                    set line {}
                } else {
                    return
                }
            }
            # scan for BANK lines
            if {[string first BANK $line] == 0} {
                scan $line "BANK%d" num
                lappend newhist(banklist) $num
            }
            # check for "Instrument parameter file" line
            if {$i == 2 && [string first "Instrument parameter" $line] == 0} {
                validateinstfile $np \
                        [file join [file dirname $inp] \
                        [string trim [string range $line 26 end]]]
            }
        }
    } else {
        # is the file one big record?
        set len [gets $in line]
        # a instrument parameter file should be more than 4 lines
        if {$len <= 4*80} {
            set ans [tk_dialog .err "Read error" \
                    "File $inp is not direct access. OK to convert?" \
                    error 0 OK QUIT]
            if {$ans == 0} {
                close $in
                set oldname ${inp}.original
                file rename $inp $oldname
                if [catch {
                    exec [file join $expgui(gsasexe) convstod] < \
                            $oldname > $inp
                } errmsg] {
                    tk_dialog .warn Notify \
                            "Error in conversion:\n$errmsg" warning 0 OK
                }
                set in [open $inp r]
                set line {}
            } else {
                return
            }
        }
        seek $in 0
        set i 0
        while {[string length [set line [read $in 80]]] == 80} {
            incr i
            # scan for BANK lines
            if {[string first BANK $line] == 0} {
                scan $line "BANK%d" num
                lappend newhist(banklist) $num
            }
            # check for "Instrument parameter file" line
            if {$i == 2 && [string first "Instrument parameter" $line] == 0} {
                validateinstfile $np \
                        [file join [file dirname $inp] \
                        [string trim [string range $line 26 end]]]
            }
        }
    }
    # were banks found?
    if {$newhist(banklist) == ""} {
        tk_dialog .err "Read error" \
                "File $inp has no BANK lines. This is not a valid GSAS data file." \
                error 0 OK
        return
    }
    # don't use a full path unless needed
    if {[pwd] == [file dirname $inp]} {
        set newhist(rawfile) [file tail $inp]
    } else {
        set newhist(rawfile) $inp
    }
    foreach i $newhist(banklist) {
        pack [radiobutton $np.bank.$i -text $i \
                -variable newhist(banknum) -value $i] -side left
        # only 1 choice, so set it
        if {[llength $newhist(banklist)] == 1} {set newhist(banknum) $i}
    }
}

proc getinstfile {np} {
    global newhist tcl_platform
    if {$tcl_platform(platform) == "windows"} {
        set inp [
        tk_getOpenFile -parent $np -initialfile $newhist(instfile) -filetypes {
            {"Inst files" .INST} {"Inst files" .INS} 
            {"Inst files" .PRM} {"All files" *}
        }
        ]
    } else {
        set inp [
        tk_getOpenFile -parent $np -initialfile $newhist(instfile) -filetypes {
            {"Inst files" .INS*} {"Inst files" .ins*} 
            {"Inst files" .PRM}  {"Inst files" .prm} 
            {"All files" *}
        }
        ]
    }
    validateinstfile $np $inp
}

proc validateinstfile {np inp} {
    global tcl_platform expgui newhist
    if {$inp == ""} return
    if [catch {set in [open $inp r]}] {
        tk_dialog .err "Open error" "Unable to open file $inp" \
                error 0 OK
        return 
    }
    set newhist(instbanks) {}
    foreach child [pack slaves $np.set] {destroy $child}
    # is this a properly formatted file?
    if {$tcl_platform(platform) == "windows"} {
        # are lines the correct length?

        #--> can we check that lines are terminated CR-LF?

        while {[set len [gets $in line]] > 0} {
            if {$len != 80} {
                set ans [tk_dialog .err "Read error" \
                        "File $inp is not direct access. OK to convert?" \
                        error 0 OK QUIT]
                if {$ans == 0} {
                    close $in
                    WinCvt $inp
                    set in [open $inp r]
                    set line {}
                } else {
                    return
                }
            }
            # scan for the INS   BANK line
            if {[string first "INS   BANK" $line] == 0} {
                set newhist(instbanks) \
                        [string trim [string range $line 12 end]]
            }
        }
    } else {
        # is the file one big record?
        set len [gets $in line]
        if {$len <= 80} {
            set ans [tk_dialog .err "Read error" \
                    "File $inp is not direct access. OK to convert?" \
                    error 0 OK QUIT]
            if {$ans == 0} {
                close $in
                set oldname ${inp}.original
                file rename $inp $oldname
                if [catch {
                    exec [file join $expgui(gsasexe) convstod] < \
                            $oldname > $inp
                } errmsg] {
                    tk_dialog .warn Notify \
                            "Error in conversion:\n$errmsg" warning 0 OK
                }
                set in [open $inp r]
                set line {}
            } else {
                return
            }
        }
        seek $in 0
        while {[string length [set line [read $in 80]]] == 80} {
            # scan for the INS   BANK line
            if {[string first "INS   BANK" $line] == 0} {
                set newhist(instbanks) \
                        [string trim [string range $line 12 end]]
            }
        }
    }
    # were banks found?
    if {$newhist(instbanks) == ""} {
        tk_dialog .err "Read error" \
                "File $inp has no INS   BANK line. This is not a valid GSAS Instrument Parameter file." \
                error 0 OK
        return
    }
    # don't use a full path unless needed
    if {[pwd] == [file dirname $inp]} {
        set newhist(instfile) [file tail $inp]
    } else {
        set newhist(instfile) $inp
    }
    for {set i 1} {$i <= $newhist(instbanks)} {incr i} {
        pack [radiobutton $np.set.$i -text $i \
                -variable newhist(setnum) -value $i] -side left
        if {$newhist(instbanks) == 1} {set newhist(setnum) $i}
    }
}

proc addhist {np} {
    global expgui newhist
    # validate the input
    set err {}
    if {[string trim $newhist(rawfile)] == ""} {
        append err "  No data file specified\n"
    }
    if {[string trim $newhist(instfile)] == ""} {
        append err "  No instrument parameter file specified\n"
    }
    if {[string trim $newhist(banknum)] == ""} {
            append err "  Bank number must be specified\n"
    } elseif {[catch {expr $newhist(banknum)}]} {
            append err "  Bank number is not valid\n"
    }
    if {[string trim $newhist(setnum)] == ""} {
        append err "  Parameter set number must be specified\n"
    } elseif {[catch {expr $newhist(setnum)}]} {
        append err "  Parameter set number is not valid\n"
    }
    if {[string trim $newhist(2tLimit)] == ""} {
        append err "  2Theta/d-space limit must be specified\n"
    } elseif {[catch {expr $newhist(2tLimit)}]} {
        append err "  The 2Theta/d-space limit is not valid\n"
    }
    if {[string trim $newhist(LimitMode)] == ""} {
        append err "  Please choose between either a 2Theta or d-space limit\n"
    }

    if {$err != ""} {
        tk_dialog .phaseerr "Add Histogram Error" \
                "The following error(s) were found in your input:\n$err" \
                error 0 "OK" 
        return
    }

    # ok do it!
    set fp [open exptool.in w]
    puts $fp "H"
    puts $fp $newhist(rawfile)
    puts $fp $newhist(instfile)
    puts $fp $newhist(banknum)
    puts $fp $newhist(setnum)
    if {$newhist(LimitMode)} {
        puts $fp "T"
    } else {
        puts $fp "D"
    }
    puts $fp "$newhist(2tLimit)"
    puts $fp "/"
    puts $fp "X"
    puts $fp "X"
    close $fp
    global tcl_platform
    # Save the current exp file
    savearchiveexp
    # disable the file changed monitor
    set expgui(expModifiedLast) 0
    set expnam [file root [file tail $expgui(expfile)]]
    catch {
        if {$tcl_platform(platform) == "windows"} {
            exec [file join $expgui(gsasexe) exptool.exe] $expnam \
                    < exptool.in >& exptool.out
        } else {
            exec [file join $expgui(gsasexe) exptool] $expnam \
                    < exptool.in >& exptool.out
        }
    } errmsg
    # load the revised exp file
    loadexp $expgui(expfile)
    set fp [open exptool.out r]
    set out [read $fp]
    close $fp
    destroy $np
    if {$errmsg != ""} {
        append errmsg "\n" $out
    } else {
        set errmsg $out
    }
    ShowBigMessage \
                 $np \
                 "Please review the result from adding the phase" \
                 $errmsg
    file delete exptool.in exptool.out
}

proc MakeAddAtomsBox {phase} {
    global expmap

    # is there room for more atoms? Well, we will check this later
    if {$phase == ""} return
    if {[llength $phase] != 1} return

    set np .newatoms
    catch {destroy $np}
    toplevel $np

    grid [label $np.l1 -text "Adding atoms to phase #$phase"] \
            -column 0 -row 0 -sticky w -columnspan 10
#    grid [label $np.l2 -text "Phase title:"] -column 0 -row 1 
    set row 1
    set col -1
    foreach i {Atom\ntype Name x y z Occ Uiso} {
        grid [label $np.l_${row}$i -text $i] -column [incr col] -row $row
    }

    set row 2
    set col -1
    grid [entry $np.e${row}t -width 5] -column [incr col]  -row $row
    grid [entry $np.e${row}n -width 8] -column [incr col]  -row $row
    foreach i {x y z o u} {
        grid [entry $np.e${row}$i -width 12] -column [incr col] -row $row
    }
    # default occupancy
    $np.e${row}o delete 0 end
    $np.e${row}o insert end 1.0
    # default Uiso
    $np.e${row}u delete 0 end
    $np.e${row}u insert end 0.025
    # default occupancy
    $np.e${row}n delete 0 end
    $np.e${row}n insert end (default)

    grid [button $np.b1 -text Add \
            -command "addatom $phase $np"] -column 2 -row 3
    bind $np <Return> "addatom $phase $np"
    grid [button $np.b2 -text Cancel \
            -command "destroy $np"] -column 3 -row 3
    
    wm title $np "add new atom"

    # grab focus, etc.
    putontop $np

    tkwait window $np

    # fix focus...
    afterputontop
}

proc addatom {phase np} {
    global expgui env
    # validate the input
    set err {}
    set row 2
    if {[set type [string trim [$np.e${row}t get]]] == ""} {
        append err "  No atom type specified\n"
    }

    set name [string trim [$np.e${row}n get]]
    if {$name == "(default)"} {set name "/"}
    if {$name == ""} {set name "/"}

    foreach i {x y z o u} n {x y z Occ Uiso} {
        if {[set $i [string trim [$np.e${row}$i get]]] == ""} {
            append err "  No value specified for $n\n"
        } elseif {[catch {expr [set $i]}]} {
            append err "  The value for $n is invalid\n"
        }
    }

    if {$err != ""} {
        tk_dialog .phaseerr "Add Atom Error" \
                "The following error(s) were found in your input:\n$err" \
                error 0 "OK" 
        return
    }

    # ok do it!
    set fp [open exptool.in w]
    puts $fp "A"
    puts $fp $phase
    # for now, only one atom at a time
    puts $fp 1
    puts $fp "$type $x $y $z $o $name I $u"
    close $fp
    # needed in UNIX
    set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
    # needed in Windows
    set env(GSAS) [file nativename $expgui(gsasdir)]
    global tcl_platform
    # Save the current exp file
    savearchiveexp
    # disable the file changed monitor
    set expgui(expModifiedLast) 0
    set expnam [file root [file tail $expgui(expfile)]]
    catch {
        if {$tcl_platform(platform) == "windows"} {
            exec [file join $expgui(gsasexe) exptool.exe] $expnam \
                    < exptool.in >& exptool.out
        } else {
            exec [file join $expgui(gsasexe) exptool] $expnam \
                    < exptool.in >& exptool.out
        }
    } errmsg
    # load the revised exp file
    loadexp $expgui(expfile)
    set fp [open exptool.out r]
    set out [read $fp]
    close $fp
    destroy $np
    if {$errmsg != ""} {
        append errmsg "\n" $out
    } else {
        set errmsg $out
    }
    ShowBigMessage \
                 $np \
                 "Please review the result from adding the atom" \
                 $errmsg
    file delete exptool.in exptool.out
}