source: branches/sandbox/rigid.tcl @ 1112

Last change on this file since 1112 was 1112, checked in by toby, 10 years ago

fix save as bug, expand rb.tcl to delete & handle gaps in body lists; likewise in rigid.tcl

File size: 19.4 KB
Line 
1 #proc RB_Load_RBdata   loads rigid body data
2 #proc RB_Load_Mapdata  loads rigid body mapping data
3 #proc RB_Control_Panel
4 #proc RB_View_Matrix
5 #proc RB_Populate
6
7# debug code to load test files when run as an independent script
8if {[array name expgui shell] == ""} {
9    lappend auto_path c:/gsas/expgui
10    package require Tk
11    package require BWidget
12    #package require La
13    #namespace import La::*
14    source c:/gsas/sandboxexpgui/readexp.tcl
15    source c:/gsas/sandboxexpgui/gsascmds.tcl
16    source c:/gsas/sandboxexpgui/rb.tcl
17    expload rb6.exp
18    mapexp
19} else {
20    source [file join $expgui(scriptdir) rb.tcl]
21}
22
23############################################################
24#global variables generated by RB_Load (x = rigid body number
25#                                       y = matrix number
26#                                       z = coordinate number
27#          ::rb_map(x)          number of times rigid body is mapped.
28#          ::rb_matrix_num(x)   number of matrices in rigid body.
29#          ::rb_mult(x,y)       multiplier for matrix.
30#          ::rb_damp(x,y)       damping factor for matrix.
31#          ::rb_var(x,y)        variable for matrix.
32#          ::rb_coord_num(x,y)  number of coordinates associated with matrix.
33#          ::rb_coord(x,y,z)    coordinates
34#          ::rb_phase_list      list of phases
35
36proc RB_Load_RBdata {args} {
37     catch {unset ::rb}
38#Loop over the rigid body types in EXP file
39    foreach i [RigidBodyList] {
40             set rb($i) [ReadRigidBody $i]
41             #Set the number of times rigid body is mapped.
42             set ::rb_map($i) [lindex $rb($i) 0]
43             puts "rigid body $i was mapped $::rb_map($i) times"
44
45             #define the matrices
46             set rb_mat [lindex $rb($i) 1]
47             set ::rb_matrix_num($i) [llength $rb_mat]
48             puts "Number of matrices in rigid body $i = $::rb_matrix_num($i)"
49
50             for {set j 1} {$j <= $::rb_matrix_num($i)} {incr j} {
51                 set temp [lindex $rb_mat [expr $j - 1]]
52                 set ::rb_mult($i,$j) [lindex $temp 0]
53                 set ::rb_damp($i,$j) [lindex $temp 1]
54                 set ::rb_var($i,$j)  [lindex $temp 2]
55                 puts "mult = $::rb_mult($i,$j), damp = $::rb_damp($i,$j), variable = $::rb_var($i,$j)"
56                 set coords [lindex $temp 3]
57                 set ::rb_coord_num($i,$j) [llength $coords]
58                 puts "number of coordinates = $::rb_coord_num($i,$j)"
59                 for {set k 0} {$k < $::rb_coord_num($i,$j)} {incr k} {
60                     set ::rb_coord($i,$j,$k) [lindex $coords $k]
61                     puts "coordinate [expr $k +1] = $::rb_coord($i,$j,$k)"
62                 }
63
64             }
65     }
66}
67
68
69
70############################################
71#           ::rb_map_beginning(x,y,z)   first atom in list
72#           ::rb_map_origin(x,y,z)      origin of rigid body
73#           ::rb_map_euler(x,y,z)       euler angles of rigid body
74#           ::rb_map_positions(x,y,z)   positions
75#           ::rb_map_damping(x,y,z)     damping
76#           ::rb_map_tls(x,y,z)         tls
77#           ::rb_map_tls_var(x,y,z)
78#           ::rb_map_tls_damp(x,y,z)
79proc RB_Load_Mapdata {phase rb_type map_num args} {
80     set rb_map [ReadRigidBodyMapping $phase $rb_type $map_num]
81     set ::rb_map_beginning($phase,$rb_type,$map_num) [lindex $rb_map 0]
82     set ::rb_map_origin($phase,$rb_type,$map_num) [lindex $rb_map 1]
83     set ::rb_map_euler($phase,$rb_type,$map_num) [lindex $rb_map 2]
84     set ::rb_map_positions($phase,$rb_type,$map_num) [lindex $rb_map 3]
85     set ::rb_map_damping($phase,$rb_type,$map_num) [lindex $rb_map 4]
86     set ::rb_map_tls($phase,$rb_type,$map_num) [lindex $rb_map 5]
87     set ::rb_map_tls_var($phase,$rb_type,$map_num) [lindex $rb_map 6]
88     set ::rb_map_tls_damp($phase,$rb_type,$map_num) [lindex $rb_map 7]
89}
90
91
92proc RB_View_Matrix {x args} {
93     catch {destroy .viewmatrix}
94     set vm .viewmatrix
95     toplevel $vm
96     wm title $vm "View Matrices for Rigid Body $x"
97     grid [label $vm.lblm -text "Matrix Number"] -row 2 -column 0
98     grid [label $vm.lbldamp -text "Matrix Multiplier"] -row 3 -column 0
99     grid [label $vm.lblvar -text "Matrix Damping Factor"] -row 4 -column 0
100
101     set y 1
102     for {set z 0} {$z < $::rb_coord_num($x,$y)} {incr z} {
103         label $vm.lbls$z -text "Site [expr $z+ 1]"
104         grid $vm.lbls$z -row [expr $z+5] -column 0
105     }
106
107     for {set y 1} {$y <= $::rb_matrix_num($x)} {incr y} {
108         grid [label $vm.lblm$y -text "Matrix #$y"] -row 2 -column $y
109         grid [entry $vm.mult$y -textvariable ::rb_mult($x,$y)] -row 3 -column $y
110         grid [entry $vm.damp$y -textvariable ::rb_damp($x,$y)] -row 4 -column $y
111         for {set z 0} {$z < $::rb_coord_num($x,$y)} {incr z} {
112             label $vm.lblc$y$z -text $::rb_coord($x,$y,$z)
113             grid $vm.lblc$y$z -row [expr $z+5] -column $y
114         }
115     }
116
117     putontop $vm
118}
119
120proc RB_View_Parameters {phase x y args} {
121   set euler     $::rb_map_euler($phase,$x,$y)
122   set positions $::rb_map_positions($phase,$x,$y)
123   set damping   $::rb_map_damping($phase,$x,$y)
124   catch {destroy .viewparam}
125   set vp .viewparam
126   toplevel $vp
127   wm title $vp "Refinement Options"
128   frame $vp.con -bd 2 -relief groove
129   frame $vp.spa -bd 2 -relief groove
130   frame $vp.refflag -bd 2 -relief groove
131   grid $vp.con -row 0 -column 0
132
133   grid $vp.spa -row 2 -column 0
134   grid $vp.refflag -row 1 -column 0
135
136   set con $vp.con
137   label $con.lbl -text "Refine: "
138   button $con.tog -text "off"
139   grid $con.lbl -row 0 -column 0
140   grid $con.tog -row 0 -column 1
141
142   grid [label $vp.spa.lbl1 -text "Supplemental Position Angles"] row 0 -column 0 -columnspan 3
143   set ::e_angle1$y [lindex [lindex $euler 3] 0]
144
145   set ::e_angle2$y [lindex [lindex $euler 4] 0]
146   set ::e_angle3$y [lindex [lindex $euler 5] 0]
147   grid [label $vp.spa.angle1l -text "Sup. Angle 1"] -row 1 -column 0
148   grid [label $vp.spa.angle2l -text "Sup. Angle 2"] -row 2 -column 0
149   grid [label $vp.spa.angle3l -text "Sup. Angle 3"] -row 3 -column 0
150   grid [entry $vp.spa.angle1 -textvariable ::e_angle1$y] -row 1 -column 1
151   grid [entry $vp.spa.angle2 -textvariable ::e_angle2$y] -row 2 -column 1
152   grid [entry $vp.spa.angle3 -textvariable ::e_angle3$y] -row 3 -column 1
153
154   set e_axis1 [lindex [lindex $euler 3] 1]
155   set e_axis2 [lindex [lindex $euler 4] 1]
156   set e_axis3 [lindex [lindex $euler 5] 1]
157
158   grid [label $vp.refflag.lbl1 -text "Refinement Flags"] -row 0 -column 0 -columnspan 3
159   grid [label $vp.refflag.x_axis -text "X-axis"] -row 1 -column 0
160   grid [label $vp.refflag.y_axis -text "Y-axis"] -row 1 -column 1
161   grid [label $vp.refflag.z_axis -text "Z-axis"] -row 1 -column 2
162   grid [label $vp.refflag.euler1 -text "Euler Angle 1"] -row 3 -column 0
163   grid [label $vp.refflag.euler2 -text "Euler Angle 2"] -row 3 -column 1
164   grid [label $vp.refflag.euler3 -text "Euler Angle 3"] -row 3 -column 2
165   grid [label $vp.refflag.sup1 -text "Sup. Angle 1"] -row 5 -column 0
166   grid [label $vp.refflag.sup2 -text "Sup. Angle 2"] -row 5 -column 1
167   grid [label $vp.refflag.sup3 -text "Sup. Angle 3"] -row 5 -column 2
168
169   for {set j 0} {$j < 9} {incr j} {
170       label $vp.refflag.$j -text [lindex $positions $j]
171   }
172   grid $vp.refflag.0 -row 2 -column 0
173   grid $vp.refflag.1 -row 2 -column 1
174   grid $vp.refflag.2 -row 2 -column 2
175   grid $vp.refflag.3 -row 4 -column 0
176   grid $vp.refflag.4 -row 4 -column 1
177   grid $vp.refflag.5 -row 4 -column 2
178   grid $vp.refflag.6 -row 6 -column 0
179   grid $vp.refflag.7 -row 6 -column 1
180   grid $vp.refflag.8 -row 6 -column 2
181
182
183
184   putontop $vp
185
186
187}
188
189
190#########################################
191#   rcb     .a               initial rigid body control panel.
192
193proc RB_Control_Panel {panelnum args} {
194     set rcb .a
195     #destroy $rcb
196     catch {toplevel $rcb} err
197     eval destroy [winfo children $rcb]
198     wm title $rcb "Rigid Body Control Panel"
199     wm geometry $rcb 700x400+10+10
200 #    frame $rcb.con -bd 2 -relief groove
201 #    grid $rcb.con -row 0 -column 0 -pady 10
202 #    button $rcb.con.create -text "Create Rigid Body"
203 #    grid $rcb.con.create -row 2 -column 0 -columnspan 2
204     set rb_nb $rcb.nb
205
206     # Enable NoteBook from BWidget package
207
208     set rb_body_list [NoteBook $rb_nb -side top]
209    # loop over rigid body types
210    set pagelist {}
211    foreach x [RigidBodyList] {
212         $rb_body_list insert $x rb_body$x -text "Rigid Body Type $x"  \
213         -raisecmd "RB_Populate $rb_body_list $x"
214        lappend pagelist rb_body$x
215     }
216     $rb_body_list insert 16 rb_body16 -text "Create Rigid Body"
217    lappend pagelist rb_body16
218     grid $rb_body_list -sticky news -column 0 -row 1 -columnspan 2
219     grid columnconfig $rcb 1 -weight 1
220     grid rowconfig    $rcb 1 -weight 1
221    $rb_body_list raise [lindex $pagelist 0]
222}
223
224
225proc RB_Populate {rb_body_list x args} {
226#arbitrary fixing of phase
227     set phase $::expmap(phaselist)
228     set pane [$rb_body_list getframe rb_body$x]
229     eval destroy [winfo children $pane]
230     set con $pane.con
231     grid [frame $con -bd 2 -relief groove] -row 0 -column 1 -pady 10
232
233     #Rigid body mapping control panel along with matrix multipliers and damping factor labels
234     grid [label  $con.rb_num -text "Rigid Body Type $x"] -row 0 -column 0 -padx 5 -pady 5
235     grid [button $con.rb_newmap -text "Map Body $x" -command "RB_Map_New $x"] -row 0 -column 1 -padx 5 -pady 5
236
237     grid [label $con.rb_mlbl1 -text "Matrix"] -row 1 -column 0
238     grid [label $con.rb_mlbl2 -text "Multiplier"] -row 2 -column 0
239     grid [label $con.rb_mlbl3 -text "Damping Factor"] -row 3 -column 0
240     grid [button $con.plot -text "Plot Rigid Body" -command "PlotRBtype $x"] -row 4 -column 0
241
242     for {set a 1} {$a <= $::rb_matrix_num($x)} {incr a} {
243        grid [label $con.rb_mm$a   -text "$a"]                -row 1 -column $a
244        grid [label $con.rb_mult$a -text "$::rb_mult($x,$a)"] -row 2 -column $a
245        grid [label $con.rb_damp$a -text "$::rb_damp($x,$a)"] -row 3 -column $a
246     }
247
248     button $con.rb_vmatrix -text "Edit Matrix Info" -command "RB_View_Matrix $x"
249     grid   $con.rb_vmatrix -row 4 -column 1 -padx 5 -pady 5
250
251     foreach {top main side lbl} [MakeScrollTable $pane] {}
252     grid [label $main.rb_origin -text "Origin"] -row 0 -column 3 -columnspan 3
253     grid [label $main.rb_euler -text "Euler Angles"] -row 0 -column 6 -columnspan 3
254     grid [label $main.rb_ref -text "Phase"] -row 1 -column 2
255     #grid [label $main.rb_ref -text "Refinement"] -row 1 -column 2
256     grid [label $main.rb_map -text "Map"] -row 1 -column 1
257     grid [label $main.rb_x   -text "x"] -row 1 -column 3
258     grid [label $main.rb_y   -text "y"] -row 1 -column 4
259     grid [label $main.rb_z   -text "z"] -row 1 -column 5
260     grid [label $main.rb_euler_x -text "x"] -row 1 -column 6
261     grid [label $main.rb_euler_y -text "y"] -row 1 -column 7
262     grid [label $main.rb_euler_z -text "z"] -row 1 -column 8
263     grid [label $main.rb_opt     -text "TLS Controls"] -row 1 -column 9 -columnspan 2
264
265     set col 11
266     set y $::rb_matrix_num($x)
267     for {set z 1} {$z <= $::rb_coord_num($x,$y)} {incr z} {
268        label $main.rb_site$z -text "site $z"
269        grid $main.rb_site$z -row 1 -column $col
270        incr col
271     }
272
273     set row 2
274     foreach p $phase {
275             incr row
276             foreach z [RigidBodyMappingList $p $x] {
277                      set row [expr $row + $z]
278                      RB_Load_Mapdata $p $x $z
279                      grid [label $main.rb_map$p$z -text "$z"] -row $row -column 1
280                      grid [label $main.rb_cb$p$z -text $p] -row $row -column 2
281
282                      #grid [button $main.rb_cb$p$z -text "off" -command "RB_View_Parameters $p $x $z"] -row $row -column 2
283                      set origin $::rb_map_origin($p,$x,$z)
284                      puts $origin
285                      grid [label $main.rb_x$p$z   -text [lindex $origin 0]] -row $row -column 3
286                      grid [label $main.rb_y$p$z   -text [lindex $origin 1]] -row $row -column 4
287                      grid [label $main.rb_z$p$z   -text [lindex $origin 2]] -row $row -column 5
288                      set euler $::rb_map_euler($p,$x,$z)
289                      for {set j 0} {$j < 3} {incr j} {
290                                  set euler1 [lindex $euler $j]
291                                  set angle  [lindex $euler1 0]
292                                  set axis   [lindex $euler1 1]
293                                  label $main.rb_euler_$p$z$axis -text $angle
294                      }
295                      grid [button $main.rb_tls$p$z -text "off" -width 7] -row $row -column 9
296                      set q 1
297                      grid $main.rb_euler_$p$z$q -row $row -column 6
298                      set q 2
299                      grid $main.rb_euler_$p$z$q -row $row -column 7
300                      set q 3
301                      grid $main.rb_euler_$p$z$q -row $row -column 8
302                      set col 11
303                      set atomnum $::rb_map_beginning($p,$x,$z)
304                      for {set j 1} {$j <=$::rb_coord_num($x,$y)} {incr j} {
305                          set atom [atominfo $p $atomnum label]
306                          grid [label $main.rb_site$p$z$j -text "$atom"] -row $row -column $col
307                          incr atomnum
308                          incr col
309                      }
310             }
311     incr row
312     }
313
314     ResizeScrollTable $pane
315}
316
317proc RB_Choose_Atom {rbnum args} {
318#     set ::rb_finput ""
319    set phase $::rb_phase
320    # get the number of atoms in this type of body
321    set natoms [llength [lindex [lindex [lindex [ReadRigidBody $rbnum] 1] 0] 3]]
322    set atomlist [RigidStartAtoms $::rb_phase $natoms]
323    if {[llength $atomlist] == 0} {
324        RB_ProcessPhase $rbnum
325        return
326    }
327     catch {destroy .chooseatom}
328     set ca .chooseatom
329     toplevel $ca
330     wm title $ca "Choose Atom"
331#     puts $atomlist
332     foreach {top main side lbl} [MakeScrollTable $ca] {}
333     set row 0
334     set column 0
335     foreach atom $atomlist {
336        set label "[atominfo $phase $atom label] \($atom\)"
337# fix next line need global variable to send.
338#        button $main.$atom -text "$label" -command "set ::rb_finput [list $label]; destroy $ca"
339        button $main.$atom -text $label -command "set ::rb_finput $atom; destroy $ca"
340        incr row
341        if {$row > 5} {
342           set row 1
343           incr column
344        }
345      grid $main.$atom -row $row -column $column -padx 5 -pady 5
346      }
347      ResizeScrollTable $ca
348      putontop $ca
349      tkwait window $ca
350      afterputontop
351}
352
353
354proc RB_Map_New {x args} {
355    catch {unset ::rb_finput}
356    set ::rb_finput ""
357    set ::body_type $x
358    catch {destroy .newmap}
359    set nm .newmap
360    toplevel $nm
361    wm title $nm "Map Rigid Body #$x"
362    set ::phase 1
363    set nmap [expr $::rb_map($x) + 1]
364    eval tk_optionMenu $nm.pinput ::rb_phase $::expmap(phaselist)
365
366    grid [label $nm.phase -text "Phase: "] -row 3 -column 1
367    grid [label $nm.f_atom -text "Choose first atom Number"] -row 4 -column 1
368    grid [label $nm.origin -text "input origin in fractional coordinates: "] -row 6 -column 1
369    grid [label $nm.euler -text "input Euler angles: "] -row 7 -column 1
370
371
372    grid [entry $nm.finputm -textvariable ::rb_finput -width 8 -takefocus 1] -row 4 -column 2
373
374    foreach item [trace vinfo ::rb_finput] {
375            eval trace vdelete ::rb_finput $item
376    }
377    trace variable ::rb_finput w "RB_Atom_List \$::rb_phase \$::rb_finput $nm $x 1"
378
379    grid [button $nm.finput -text "list allowed" -command "RB_Choose_Atom $x"] -row 4 -column 3
380    grid [label $nm.o1l -text "x"] -row 5 -column 2
381    grid [label $nm.o2l -text "y"] -row 5 -column 3
382    grid [label $nm.o3l -text "z"] -row 5 -column 4
383    grid [entry $nm.o1 -width 8 -textvariable ::origin1 -takefocus 1] -row 6 -column 2
384    grid [entry $nm.o2 -width 8 -textvariable ::origin2 -takefocus 1] -row 6 -column 3
385    grid [entry $nm.o3 -width 8 -textvariable ::origin3 -takefocus 1] -row 6 -column 4
386    grid [entry $nm.e1 -width 8 -textvariable ::euler1 -takefocus 1] -row 7 -column 2
387    grid [entry $nm.e2 -width 8 -textvariable ::euler2 -takefocus 1] -row 7 -column 3
388    grid [entry $nm.e3 -width 8 -textvariable ::euler3 -takefocus 1] -row 7 -column 4
389
390    grid $nm.pinput -row 3 -column 3
391
392
393
394    grid [button $nm.plot -text "Plot Rigid Body & Phase" -command "PlotStrBody $x"] -row 8 -column 2 -columnspan 3
395    grid [frame $nm.l] -row 9 -column 2 -columnspan 3
396    grid [button $nm.l.s -text "Save" -width 6 -command {RB_Write_Map}] -column 1 -row 1
397    grid [button $nm.l.q -text "Quit" -width 6 -command "destroy $nm"] -column 2  -row 1
398
399    foreach item [trace vinfo ::rb_phase] {
400            eval trace vdelete ::rb_phase $item
401    }
402    trace variable ::rb_phase w "RB_ProcessPhase $x"
403    set ::rb_phase ""
404}
405
406proc PlotStrBody {rbtype} {
407     set Euler [list "1 $::euler1" "2 $::euler2" "3 $::euler3"]
408     set origin "$::origin1 $::origin2 $::origin3"
409     set phase $::rb_phase
410     set cell {}
411     foreach p {a b c alpha beta gamma} {
412        lappend cell [phaseinfo $phase $p]
413    }
414    set coords [RB2cart [lindex [ReadRigidBody $rbtype] 1]]
415    set frcoords [CalcBody $Euler $cell $coords $origin]
416    #puts "CalcBody $Euler $cell $coords $origin"
417    #puts $coords
418    #puts $frcoords
419    DRAWxtlPlotRBFit $frcoords $phase $::rb_finput 0
420 }
421#
422
423proc RB_Write_Map {args} {
424   set origin "$::origin1 $::origin2 $::origin3"
425   set euler "$::euler1 $::euler2 $::euler3"
426   puts "phase = $::rb_phase"
427   puts "bodytyp = $::body_type"
428   puts "firstatom = $::rb_finput"
429   puts "position = $origin"
430   puts "Euler = $euler"
431   MapRigidBody $::rb_phase $::body_type $::rb_finput $origin $euler
432   incr ::rb_map($::body_type)
433    incr ::expgui(changed)
434   RB_Control_Panel $::body_type
435   destroy .newmap
436}
437
438proc RB_Atom_List {phase atomnum address x y args} {
439     foreach w [winfo children $address] {
440             if {[string first ".atom" $w] != -1} {destroy $w}
441     }
442     set col 8
443    if {$atomnum == ""} return
444     grid [label $address.atomlbl -text "Atoms Mapped to Rigid Body"] -row 3 -column 8 -columnspan 99
445    # get the number of atoms in this type of body
446    set natoms [llength [lindex [lindex [lindex [ReadRigidBody $x] 1] 0] 3]]   
447    set atoms [RigidStartAtoms $phase $natoms]
448    if {[lsearch $atoms $atomnum] == -1} {
449         grid [label $address.atomerr -text "(invalid 1st atom)"] -row 4 -column $col
450        return
451    }
452    set atoms [lrange $::expmap(atomlist_$phase) \
453                   [lsearch $::expmap(atomlist_$phase) $atomnum] end]
454    foreach j [lrange $atoms 0 [expr {$natoms - 1}]] {
455        set atom [atominfo $phase $j label]
456        grid [label $address.atom$phase$x$j -text $atom] -row 4 -column $col
457        incr col
458     }
459}
460
461proc RB_ProcessPhase {rbnum args} {
462    if {$::rb_phase == ""} {
463        set atoms {}
464    } else {
465        # get the number of atoms in this type of body
466        set natoms [llength [lindex [lindex [lindex [ReadRigidBody $rbnum] 1] 0] 3]]
467
468        set atoms [RigidStartAtoms $::rb_phase $natoms]
469    }
470    set nm .newmap
471    if {[llength $atoms] == 0} {
472        foreach w "$nm.finputm $nm.plot $nm.l.s" {
473            $w config -state disabled
474        }
475        $nm.finput config -text "None allowed" -state disabled
476    } else {
477        foreach w "$nm.finputm $nm.plot $nm.l.s" {
478            $w config -state normal
479        }
480        $nm.finput config -text "Show allowed" -state normal
481    }
482}
483
484RB_Load_RBdata
485RB_Control_Panel 1
Note: See TracBrowser for help on using the repository browser.