1 | # This program is under CECILL_B licence. See footer for details. |
---|
2 | |
---|
3 | |
---|
4 | # create the frame in wich an exclusive selection of model wil be done |
---|
5 | # create the menubutton used for selection |
---|
6 | proc modelxor_create { args } { |
---|
7 | |
---|
8 | set mandatory_arguments {path_father address} |
---|
9 | |
---|
10 | # Initializes the widget |
---|
11 | initWidget |
---|
12 | |
---|
13 | smartpacker_setup_modelframe $win $address |
---|
14 | |
---|
15 | set widgetInfo($address-to_reset) 0 |
---|
16 | |
---|
17 | set widgetInfo($address-status) 0 |
---|
18 | set widgetInfo($address-dependencies_status) 1 |
---|
19 | |
---|
20 | set widgetInfo($address-status_txt) "" |
---|
21 | ttk::label $win.status -textvariable widgetInfo($address-status_txt) -foreground "red" -justify center -compound left |
---|
22 | # the menubutton seclector |
---|
23 | ttk::menubutton $win.mb -menu $win.mb.xor -textvariable widgetInfo($address-variable_title) |
---|
24 | menu $win.mb.xor -tearoff 0 -postcommand [subst { modelxor_mb_refresh $win $address}] |
---|
25 | pack $win.mb |
---|
26 | pack $win.status |
---|
27 | |
---|
28 | # this frame is where all xor choices will be used |
---|
29 | #switchform_create $win.xor |
---|
30 | ttk::frame $win.xor |
---|
31 | pack $win.xor -side top -expand 1 -fill both |
---|
32 | |
---|
33 | |
---|
34 | |
---|
35 | if {[dTree_attrExists $XMLtree $full_address_XML "groups"]==1} { |
---|
36 | set widgetInfo($address-groups) 1 |
---|
37 | } else { |
---|
38 | set widgetInfo($address-groups) 0 |
---|
39 | } |
---|
40 | |
---|
41 | |
---|
42 | set widgetInfo($address-full_address_XML_clean) $full_address_XML_clean |
---|
43 | set widgetInfo($address-children) [dTree_getChildren_fast $XMLtree $full_address_XML_clean ] |
---|
44 | |
---|
45 | |
---|
46 | set main_menu_reduced "" |
---|
47 | # find the redondant childs in the menu and gather , if groups are enabled |
---|
48 | if {$widgetInfo($address-groups)} { |
---|
49 | set main_menu "" |
---|
50 | foreach child $widgetInfo($address-children) { |
---|
51 | lappend main_menu [lindex [split $child "_"] 0] |
---|
52 | } |
---|
53 | foreach category $main_menu { |
---|
54 | set items [llength [lsearch -all $main_menu $category] ] |
---|
55 | if {$items > 1} { |
---|
56 | lappend main_menu_reduced $category |
---|
57 | } |
---|
58 | } |
---|
59 | set main_menu_reduced [lsort -unique $main_menu_reduced] |
---|
60 | } |
---|
61 | |
---|
62 | set widgetInfo($address-categories) $main_menu_reduced |
---|
63 | |
---|
64 | |
---|
65 | |
---|
66 | # add the groups (if any) |
---|
67 | set widgetInfo($address-catindex-none) 0 |
---|
68 | foreach category $main_menu_reduced { |
---|
69 | menu $win.mb.xor.$category -tearoff 0 |
---|
70 | $win.mb.xor add cascade -menu $win.mb.xor.$category -label "[string totitle $category]" |
---|
71 | set widgetInfo($address-catindex-$category) 0 |
---|
72 | set widgetInfo($address-catchildren-$category) "" |
---|
73 | } |
---|
74 | |
---|
75 | |
---|
76 | set widgetInfo($address-child-conditional) "" |
---|
77 | |
---|
78 | foreach child $widgetInfo($address-children) { |
---|
79 | |
---|
80 | set title [dTree_getAttribute_fast $XMLtree "$full_address_XML_clean $child" "title"] |
---|
81 | set child_nodeType [dTree_getAttribute_fast $XMLtree "$full_address_XML_clean $child" "nodeType"] |
---|
82 | if {[dTree_attrExists $XMLtree "$full_address_XML_clean $child" "existif"] ==1 } { |
---|
83 | lappend widgetInfo($address-child-conditional) $child |
---|
84 | bind . <<visiblityChanged-$address.$child>> +[subst { eval modelxor_updatechoice_from_existifs $win $address}] |
---|
85 | } |
---|
86 | |
---|
87 | |
---|
88 | |
---|
89 | # add the command either at the root or in the groups |
---|
90 | set category [lindex [split $child "_"] 0] |
---|
91 | if {[lsearch $widgetInfo($address-categories) $category] ==-1 } { |
---|
92 | $win.mb.xor add command -label "$title" -command [subst {modelxor_mb_action $win $address $child }] |
---|
93 | set widgetInfo($address-childindex-$child) $widgetInfo($address-catindex-none) |
---|
94 | set widgetInfo($address-childmenu-$child) $win.mb.xor |
---|
95 | set widgetInfo($address-childcategory-$child) "none" |
---|
96 | lappend widgetInfo($address-catchildren-none) $child |
---|
97 | incr widgetInfo($address-catindex-none) 1 |
---|
98 | } else { |
---|
99 | $win.mb.xor.$category add command -label "$title" -command [subst {modelxor_mb_action $win $address $child }] |
---|
100 | set widgetInfo($address-childindex-$child) $widgetInfo($address-catindex-$category) |
---|
101 | set widgetInfo($address-childmenu-$child) $win.mb.xor.$category |
---|
102 | set widgetInfo($address-childcategory-$child) "$category" |
---|
103 | lappend widgetInfo($address-catchildren-$category) $child |
---|
104 | incr widgetInfo($address-catindex-$category) 1 |
---|
105 | } |
---|
106 | } |
---|
107 | |
---|
108 | # Finishes the widget |
---|
109 | # append widgetInfo($address-check) [ subst {modelxor_check $win $address}] |
---|
110 | append widgetInfo($address-refreshStatus) [ subst {modelxor_refreshStatus $win $address}] |
---|
111 | |
---|
112 | finishWidget |
---|
113 | |
---|
114 | help_add_desc_docu_to_widget |
---|
115 | |
---|
116 | # initialize the layout by the default |
---|
117 | modelxor_mb_action $win $address $widgetInfo($address-variable) |
---|
118 | |
---|
119 | |
---|
120 | # clean the widget callBack on dstruction |
---|
121 | bind $win <Destroy> [ subst {widget_destroy $win $address}] |
---|
122 | |
---|
123 | return $win |
---|
124 | } |
---|
125 | |
---|
126 | proc modelxor_mb_refresh {win address} { |
---|
127 | global widgetInfo XMLtree tmpTree |
---|
128 | |
---|
129 | set full_address_XML_clean $widgetInfo($address-full_address_XML_clean) |
---|
130 | # Updates of existifs in the menu |
---|
131 | foreach child $widgetInfo($address-child-conditional) { |
---|
132 | set existifArg [build_existIf_argument "$full_address_XML_clean $child"] |
---|
133 | set existIfArgument [join [lindex $existifArg 0] " "] |
---|
134 | if {[expr $existIfArgument]} { |
---|
135 | $widgetInfo($address-childmenu-$child) entryconfigure $widgetInfo($address-childindex-$child) -state normal |
---|
136 | lappend child_authorized $child |
---|
137 | } else { |
---|
138 | $widgetInfo($address-childmenu-$child) entryconfigure $widgetInfo($address-childindex-$child) -state disabled |
---|
139 | } |
---|
140 | } |
---|
141 | |
---|
142 | } |
---|
143 | |
---|
144 | |
---|
145 | |
---|
146 | proc modelxor_mb_action { win address setchild } { |
---|
147 | global widgetInfo XMLtree tmpTree |
---|
148 | |
---|
149 | |
---|
150 | # update the value |
---|
151 | if { $widgetInfo($address-variable) != $setchild} { |
---|
152 | set widgetInfo($address-variable) $setchild |
---|
153 | eval $widgetInfo($address-check) |
---|
154 | } |
---|
155 | |
---|
156 | } |
---|
157 | |
---|
158 | |
---|
159 | proc modelxor_updatechoice_from_existifs {win address} { |
---|
160 | global widgetInfo |
---|
161 | |
---|
162 | set initStatus $widgetInfo($address-status) |
---|
163 | set widgetInfo($address-dependencies_status) "1" |
---|
164 | |
---|
165 | |
---|
166 | |
---|
167 | |
---|
168 | set child $widgetInfo($address-variable) |
---|
169 | if { $child in $widgetInfo($address-child-conditional) } { |
---|
170 | if {$widgetInfo($address.$child-visible) == 0 } { |
---|
171 | warning "XOR $address cannot keep $widgetInfo($address-variable)" |
---|
172 | |
---|
173 | set widgetInfo($address-dependencies_status) "-1" |
---|
174 | $win.status configure -image icon_flag |
---|
175 | set widgetInfo($address-status_txt) "$widgetInfo($address-variable) is not a possible choice" |
---|
176 | } |
---|
177 | } |
---|
178 | |
---|
179 | set widgetInfo($address-status) [expr min($widgetInfo($address-status),$widgetInfo($address-dependencies_status)) ] |
---|
180 | |
---|
181 | # commented for the moment. Might be a need. |
---|
182 | #if {$initStatus != $widgetInfo($address-status)} { |
---|
183 | #UpdateValidationStatus $address |
---|
184 | #} |
---|
185 | } |
---|
186 | |
---|
187 | |
---|
188 | proc modelxor_refreshStatus {win address} { |
---|
189 | global widgetInfo XMLtree tmpTree |
---|
190 | |
---|
191 | set full_address_XML_clean $widgetInfo($address-full_address_XML_clean) |
---|
192 | |
---|
193 | set widgetInfo($address-status_txt) "" |
---|
194 | $win.status configure -image "" |
---|
195 | |
---|
196 | |
---|
197 | # l'enfant actuellement affiche |
---|
198 | set currentchild [lindex [split [winfo children $win.xor] "."] end ] |
---|
199 | |
---|
200 | # l'enfant qu'il faudrait afficher |
---|
201 | set child $widgetInfo($address-variable) |
---|
202 | |
---|
203 | |
---|
204 | |
---|
205 | set refreshxor 0 |
---|
206 | # si l'enfant actuellemnt affiche n'est pas le bon |
---|
207 | if {$currentchild != $child } { |
---|
208 | modelxor_killchild $win $address $currentchild |
---|
209 | set refreshxor 1 |
---|
210 | } |
---|
211 | # si il faut reinitialiser l'onglet |
---|
212 | if {$widgetInfo($address-to_reset) == 1} { |
---|
213 | #debug ">>>> reinit $address.$child " |
---|
214 | destroy $win.xor.$child |
---|
215 | set refreshxor 1 |
---|
216 | set widgetInfo($address-to_reset) 0 |
---|
217 | } |
---|
218 | |
---|
219 | |
---|
220 | # create new memory and gui |
---|
221 | if { $refreshxor == 1} { |
---|
222 | #debug ">>>> creating $address.$child " |
---|
223 | set winchild $win.xor.$child |
---|
224 | ttk::frame $winchild |
---|
225 | pack $winchild -side top -expand 1 -fill both |
---|
226 | set child_nodeType [dTree_getAttribute_fast $XMLtree "$full_address_XML_clean $child" "nodeType"] |
---|
227 | set newpart [gui_addpart -address $address.$child -path_father $winchild -class $child_nodeType -style "flat"] |
---|
228 | CheckFamily $address.$child |
---|
229 | } |
---|
230 | |
---|
231 | |
---|
232 | set widgetInfo($address-variable_title) [dTree_getAttribute_fast $XMLtree "$widgetInfo($address-full_address_XML_clean) $widgetInfo($address-variable)" "title"] |
---|
233 | |
---|
234 | smartpacker_update_visibility $win $address |
---|
235 | modelxor_updatechoice_from_existifs $win $address |
---|
236 | |
---|
237 | |
---|
238 | |
---|
239 | } |
---|
240 | |
---|
241 | proc modelxor_killchild {win address child} { |
---|
242 | global widgetInfo |
---|
243 | global tmpTree |
---|
244 | if {$child ==""} {return} |
---|
245 | |
---|
246 | #debug ">>>> killing $address.$child" |
---|
247 | destroy $win.xor.$child |
---|
248 | # clean widget info |
---|
249 | array unset widgetInfo $address.$child\* |
---|
250 | # destroy tmptree information |
---|
251 | set full_address_XML [split $address.$child "."] |
---|
252 | if {[dTree_nodeExists $tmpTree $full_address_XML]} { |
---|
253 | dTree_rmBranch tmpTree $full_address_XML |
---|
254 | } |
---|
255 | return |
---|
256 | } |
---|
257 | |
---|
258 | |
---|
259 | |
---|
260 | |
---|
261 | # Copyright CERFACS 2014 |
---|
262 | # |
---|
263 | # antoine.dauptain@cerfacs.fr |
---|
264 | # |
---|
265 | # This software is a computer program whose purpose is to ensure technology |
---|
266 | # transfer between academia and industry. |
---|
267 | # |
---|
268 | # This software is governed by the CeCILL-B license under French law and |
---|
269 | # abiding by the rules of distribution of free software. You can use, |
---|
270 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
---|
271 | # license as circulated by CEA, CNRS and INRIA at the following URL |
---|
272 | # "http://www.cecill.info". |
---|
273 | # |
---|
274 | # As a counterpart to the access to the source code and rights to copy, |
---|
275 | # modify and redistribute granted by the license, users are provided only |
---|
276 | # with a limited warranty and the software's author, the holder of the |
---|
277 | # economic rights, and the successive licensors have only limited |
---|
278 | # liability. |
---|
279 | # |
---|
280 | # In this respect, the user's attention is drawn to the risks associated |
---|
281 | # with loading, using, modifying and/or developing or reproducing the |
---|
282 | # software by the user in light of its specific status of free software, |
---|
283 | # that may mean that it is complicated to manipulate, and that also |
---|
284 | # therefore means that it is reserved for developers and experienced |
---|
285 | # professionals having in-depth computer knowledge. Users are therefore |
---|
286 | # encouraged to load and test the software's suitability as regards their |
---|
287 | # requirements in conditions enabling the security of their systems and/or |
---|
288 | # data to be ensured and, more generally, to use and operate it in the |
---|
289 | # same conditions as regards security. |
---|
290 | # |
---|
291 | # The fact that you are presently reading this means that you have had |
---|
292 | # knowledge of the CeCILL-B license and that you accept its terms. |
---|