Changeset 1114 for branches

Timestamp:

Feb 14, 2011 1:14:00 PM (13 years ago)

Author:

toby

Message:

more RB capability

Location:

branches/sandbox

Files:

• rb.tcl (modified) (3 diffs)
• rigid.tcl (modified) (4 diffs)

branches/sandbox/rb.tcl

@@ -1448 +1448 @@
     if {$app == ""} {
         MyMessageBox -parent . -title "No DRAWxtl" \
-                -message "Sorry, DRAWxtl is not installed no phases are present to write" \
+                -message "Sorry, DRAWxtl is not installed" \
                 -icon warning
         return
@@ -1472 +1472 @@
     if {$app == ""} {
         MyMessageBox -parent . -title "No DRAWxtl" \
-                -message "Sorry, DRAWxtl is not installed no phases are present to write" \
+                -message "Sorry, DRAWxtl is not installed" \
                 -icon warning
         return
@@ -1504 +1504 @@
     if {$app == ""} {
         MyMessageBox -parent . -title "No DRAWxtl" \
-                -message "Sorry, DRAWxtl is not installed no phases are present to write" \
+                -message "Sorry, DRAWxtl is not installed" \
                 -icon warning
         return

branches/sandbox/rigid.tcl

@@ -392 +392 @@
 
 
-    grid [button $nm.plot -text "Plot Rigid Body & Phase" -command "PlotStrBody $x"] -row 8 -column 2 -columnspan 3
+    grid [frame $nm.p] -row 8 -column 1 -columnspan 4 -sticky e
+    grid [button $nm.p.fit -text "Fit rigid body to phase" -command "FitBody2coords $x $nm"] -row 0 -column 1 
+    grid [button $nm.p.plot -text "Plot rigid body & phase" -command "PlotStrBody $x $nm"] -row 1 -column 1
+    grid [label $nm.p.l -text "Bonds: "] -row 1 -column 2 
+    grid [entry $nm.p.e] -row 1 -column 3
+    $nm.p.e delete 0 end
+    $nm.p.e insert 0 "0.9-1.1, 1.3-1.6"
+
     grid [frame $nm.l] -row 9 -column 2 -columnspan 3
     grid [button $nm.l.s -text "Save" -width 6 -command {RB_Write_Map}] -column 1 -row 1
@@ -404 +411 @@
 }
 
-proc PlotStrBody {rbtype} {
+proc FitBody2coords {rbtype menu} {
+    set warn ""
+    foreach i {1 2 3} lbl {x y z} {
+        if {[string trim [set ::euler$i]] == ""} {
+            set ::euler$i 0.0
+        }
+        if {[string trim [set ::origin$i]] == ""} {
+            set ::origin$i .0
+        }
+        if {[catch {expr [set ::euler$i]}]} {
+            append warn "\tError in Euler angle around $lbl\n"
+        }
+        if {[catch {expr [set ::origin$i]}]} {
+            append warn "\tError in origin $lbl\n"
+        }
+    }
+    if {[catch {expr $::rb_finput}]} {
+        append warn "\tError in 1st atom number\n"
+    }
+    if {$warn != ""} {
+        MyMessageBox -parent $menu -title "Input error" \
+                -message "Invalid input:\n$warn" -icon warning
+        return
+    }
+    set Euler [list "1 $::euler1" "2 $::euler2" "3 $::euler3"]
+    set origin "$::origin1 $::origin2 $::origin3"
+    set phase $::rb_phase
+    set cell {}
+    foreach p {a b c alpha beta gamma} {
+        lappend cell [phaseinfo $phase $p]
+    }
+    set coords [RB2cart [lindex [ReadRigidBody $rbtype] 1]]
+    set natom [llength $coords]
+    set firstind [lsearch $::expmap(atomlist_$phase) $::rb_finput]
+    set atoms [lrange \
+                   [lrange $::expmap(atomlist_$phase) $firstind end] \
+                   0 [expr {$natom-1}]]
+    # now loop over atoms
+    set frcoords {}
+    foreach atom $atoms {
+        set xyz {}
+        foreach v {x y z} {
+            lappend xyz [atominfo $phase $atom $v]
+        }
+        lappend frcoords $xyz
+    }
+    # it would be nice to have checkboxes for each atom, but for now use em all
+    set useflags {}
+    foreach i $coords {lappend useflags 1}
+    # do the fit
+    foreach {neworigin newEuler rmsdev newfrac rmsbyatom} \
+        [FitBody $Euler $cell $coords $useflags $frcoords $origin] {}
+    foreach i {1 2 3} val $neworigin pair $newEuler {
+        set ::origin$i $val
+        set ::euler$i [lindex $pair 1]
+    }
+    # show deviations
+    foreach atom $atoms rms $rmsbyatom {
+        puts "[atominfo $phase $atom label]\t$rms"
+    }
+    #puts "CalcBody $Euler $cell $coords $origin"
+    #puts $coords
+    #puts $frcoords
+    #DRAWxtlPlotRBFit $frcoords $phase $::rb_finput 0 $bondlist $bondlist
+ }
+
+
+proc PlotStrBody {rbtype menu} {
+    set warn ""
+    foreach i {1 2 3} lbl {x y z} {
+        if {[catch {expr [set ::euler$i]}]} {
+            append warn "\tError in Euler angle around $lbl\n"
+        }
+        if {[catch {expr [set ::origin$i]}]} {
+            append warn "\tError in origin $lbl\n"
+        }
+    }
+    if {[catch {expr $::rb_finput}]} {
+        append warn "\tError in 1st atom number\n"
+    }
+    if {$warn != ""} {
+        MyMessageBox -parent $menu -title "Input error" \
+                -message "Invalid input:\n$warn" -icon warning
+        return
+    }
+    # translate bond list
+    set bl [$menu.p.e get]
+    regsub -all "," $bl " " bl
+    set bondlist {}
+    set warn ""
+    foreach b $bl {
+        if {[llength [split $b "-"]] == 2} {
+            lappend bondlist [split $b "-"]
+        } else {
+            set warn "error parsing bond list"
+        }
+    }
+    if {$warn != ""} {
+        MyMessageBox -parent . -title "Input warning" \
+                -message "Invalid bond input" -icon warning
+    }
      set Euler [list "1 $::euler1" "2 $::euler2" "3 $::euler3"]
      set origin "$::origin1 $::origin2 $::origin3"
@@ -417 +524 @@
     #puts $coords
     #puts $frcoords
-    DRAWxtlPlotRBFit $frcoords $phase $::rb_finput 0
+    DRAWxtlPlotRBFit $frcoords $phase $::rb_finput 0 $bondlist $bondlist
  }
 #
@@ -470 +577 @@
     set nm .newmap
     if {[llength $atoms] == 0} {
-        foreach w "$nm.finputm $nm.plot $nm.l.s" {
+        foreach w "$nm.finputm $nm.p.plot $nm.p.fit $nm.p.e $nm.l.s" {
             $w config -state disabled
         }
         $nm.finput config -text "None allowed" -state disabled
     } else {
-        foreach w "$nm.finputm $nm.plot $nm.l.s" {
+        foreach w "$nm.finputm $nm.p.plot $nm.p.fit $nm.p.e $nm.l.s" {
             $w config -state normal
         }