1 | # This program is under CECILL_B licence. See footer for details. |
---|
2 | |
---|
3 | |
---|
4 | |
---|
5 | |
---|
6 | # hello world |
---|
7 | |
---|
8 | # Create a GUI associated to a tree |
---|
9 | proc gui_create { args } { |
---|
10 | global widgetInfo |
---|
11 | global XMLtree |
---|
12 | global initializedSolver |
---|
13 | global solverPath |
---|
14 | global libraryPath |
---|
15 | global solverOrder |
---|
16 | |
---|
17 | set address "root" |
---|
18 | set initializedSolver "" |
---|
19 | |
---|
20 | # An initialization is mandatory for the root node but the initWidget doesn't fit requirements for the root node |
---|
21 | set widgetInfo($address-require) "" |
---|
22 | set widgetInfo($address-status) 0 |
---|
23 | set widgetInfo($address-check) "" |
---|
24 | set widgetInfo($address-refresh) "" |
---|
25 | set widgetInfo($address-refreshStatus) "" |
---|
26 | |
---|
27 | # loop on keywords provided |
---|
28 | foreach { keyword argument } $args { |
---|
29 | # test keywords |
---|
30 | if {![string match -* $keyword ]} { |
---|
31 | tk_messageBox -icon error -message "Error : keyword must be like -*" |
---|
32 | return |
---|
33 | } |
---|
34 | # assign keywords |
---|
35 | switch -- $keyword { |
---|
36 | "-path" { |
---|
37 | set win $argument |
---|
38 | } |
---|
39 | "-solver" { |
---|
40 | set solver $argument |
---|
41 | } |
---|
42 | default { |
---|
43 | tk_messageBox -icon error -message "Error : $keyword is not recognized" |
---|
44 | return |
---|
45 | } |
---|
46 | } |
---|
47 | } |
---|
48 | set widgetInfo($address-refreshStatus) "" |
---|
49 | |
---|
50 | set win_GUI [ solverframe_create -path_father $win -address "root"] |
---|
51 | |
---|
52 | # ensure that destroying the GUI frame will wipe out its associated memory |
---|
53 | bind $win_GUI <Destroy> "gui_destroy $solver" |
---|
54 | |
---|
55 | # start the recursive creation of widgets |
---|
56 | |
---|
57 | ######## Sort the children according to their "order" attribute |
---|
58 | |
---|
59 | # First, get children and associated orders |
---|
60 | foreach child [dTree_getChildren $XMLtree "root"] { |
---|
61 | set order "0" |
---|
62 | set childAndOrder "" |
---|
63 | # Retrieve order from either dict solver order (set solvers_to_add) or XML if absent |
---|
64 | if { $child in [array names solverOrder]} { |
---|
65 | set order $solverOrder($child) |
---|
66 | } else { |
---|
67 | set order [dTree_tryGetAttribute $XMLtree "root $child" order "9999"] |
---|
68 | } |
---|
69 | lappend childAndOrder $order |
---|
70 | lappend childAndOrder $child |
---|
71 | lappend childrenAndOrder $childAndOrder |
---|
72 | } |
---|
73 | |
---|
74 | # Then, sort |
---|
75 | set childrenAndOrder [lsort -index 0 -integer $childrenAndOrder] |
---|
76 | # Finally, store them |
---|
77 | foreach child $childrenAndOrder { |
---|
78 | lappend sortedChildren [lindex $child 1] |
---|
79 | } |
---|
80 | |
---|
81 | ############ Loop over children |
---|
82 | foreach solv $sortedChildren { |
---|
83 | if {$solv == "DATA"} { |
---|
84 | continue |
---|
85 | } |
---|
86 | set initializedSolver $solv |
---|
87 | set solverPath [file join $libraryPath $solv] |
---|
88 | gui_addpart -address root.$solv -path_father $win_GUI -class solver |
---|
89 | } |
---|
90 | |
---|
91 | |
---|
92 | return $win_GUI |
---|
93 | } |
---|
94 | |
---|
95 | proc gui_addpart { args } { |
---|
96 | global GuiInfo |
---|
97 | global DStree |
---|
98 | global XMLtree |
---|
99 | global additionalWidgets |
---|
100 | |
---|
101 | # set style . If style flat, simple frames will be used instead of labelframes |
---|
102 | # used for labelframed widgets in modelxor or multiple |
---|
103 | set part_style "normal" |
---|
104 | |
---|
105 | # loop on keywords provided |
---|
106 | foreach { keyword argument } $args { |
---|
107 | # test keywords |
---|
108 | if {![string match -* $keyword ]} { |
---|
109 | tk_messageBox -icon error -message "Error : keyword must be like -*" |
---|
110 | return |
---|
111 | } |
---|
112 | # assign keywords |
---|
113 | switch -- $keyword { |
---|
114 | "-address" { |
---|
115 | set address $argument |
---|
116 | set full_address_XML [split $argument "."] |
---|
117 | set node_XML [lindex $full_address_XML end ] |
---|
118 | set parent_address_XML [lrange $full_address_XML 0 end-1 ] |
---|
119 | set parent_address [join $parent_address_XML .] |
---|
120 | } |
---|
121 | "-path_father" { |
---|
122 | set path_father $argument |
---|
123 | } |
---|
124 | "-class" { |
---|
125 | set part_class $argument |
---|
126 | } |
---|
127 | "-style" { |
---|
128 | set part_style $argument |
---|
129 | } |
---|
130 | |
---|
131 | default { |
---|
132 | tk_messageBox -icon error -message "Error : $keyword is not recognized" |
---|
133 | return |
---|
134 | } |
---|
135 | } |
---|
136 | } |
---|
137 | |
---|
138 | |
---|
139 | switch -glob $part_class { |
---|
140 | "solver" { |
---|
141 | set part_winactive [solverframe_add -path_father $path_father -address $address] |
---|
142 | } |
---|
143 | "tab" { |
---|
144 | set part_winactive [tabs_add -path_father $path_father -address $address] |
---|
145 | } |
---|
146 | "model" { |
---|
147 | set part_winactive [modelframe_create -path_father $path_father -address $address -style $part_style] |
---|
148 | } |
---|
149 | "multiple" { |
---|
150 | set part_winactive [multiple_create -path_father $path_father -address $address] |
---|
151 | } |
---|
152 | "xor" { |
---|
153 | set part_winactive [modelxor_create -path_father $path_father -address $address -style $part_style] |
---|
154 | } |
---|
155 | "action" { |
---|
156 | set part_winactive [action_create -path_father $path_father -address $address -style $part_style] |
---|
157 | } |
---|
158 | "info" { |
---|
159 | set part_winactive [info_create -path_father $path_father -address $address] |
---|
160 | } |
---|
161 | "choice" { |
---|
162 | set part_winactive [choice_create -path_father $path_father -address $address] |
---|
163 | } |
---|
164 | "comment" { |
---|
165 | set part_winactive [comment_create -path_father $path_father -address $address] |
---|
166 | } |
---|
167 | "comparator" { |
---|
168 | set part_winactive [comparator_create -path_father $path_father -address $address] |
---|
169 | } |
---|
170 | "status" { |
---|
171 | set part_winactive [status_create -path_father $path_father -address $address] |
---|
172 | } |
---|
173 | "graph" { |
---|
174 | set part_winactive [graph_create -path_father $path_father -address $address] |
---|
175 | } |
---|
176 | "glance" { |
---|
177 | set part_winactive [glance_create -path_father $path_father -address $address] |
---|
178 | } |
---|
179 | "timeline" { |
---|
180 | set part_winactive [timeline_create -path_father $path_father -address $address] |
---|
181 | } |
---|
182 | "option" { |
---|
183 | set part_winactive [choice_add -path_father $path_father -address $address] |
---|
184 | } |
---|
185 | "param" { |
---|
186 | set param_type [dTree_getAttribute $XMLtree $full_address_XML "type"] |
---|
187 | |
---|
188 | switch -glob $param_type { |
---|
189 | "onoff" { |
---|
190 | set part_winactive [switch_create -path_father $path_father -address $address] |
---|
191 | } |
---|
192 | "double*" - |
---|
193 | "integer*" - |
---|
194 | "fraction" - |
---|
195 | "date" - |
---|
196 | "complex" - |
---|
197 | "string*" - |
---|
198 | "ascii*" - |
---|
199 | "vector" - |
---|
200 | "liststring" { |
---|
201 | set part_winactive [entry_create -path_father $path_father -address $address] |
---|
202 | } |
---|
203 | "list_*" { |
---|
204 | set part_winactive [cluster_create -path_father $path_father -address $address] |
---|
205 | } |
---|
206 | "selection" { |
---|
207 | set part_winactive [selection_create -path_father $path_father -address $address] |
---|
208 | } |
---|
209 | "file" - |
---|
210 | "multiple_files" - |
---|
211 | "h5_asciiBound" - |
---|
212 | "folder" { |
---|
213 | set part_winactive [browser_create -path_father $path_father -address $address] |
---|
214 | } |
---|
215 | "speccompo" { |
---|
216 | error "speccompo is not supported anymore" |
---|
217 | # set part_winactive [speccompo_create -path_father $path_father -address $address] |
---|
218 | } |
---|
219 | "labelimage" { |
---|
220 | error "labelimage is not supported anymore" |
---|
221 | #set part_winactive [labelimage_create -path_father $path_father -address $address] |
---|
222 | } |
---|
223 | default { |
---|
224 | set widget_title [dTree_getAttribute $XMLtree $full_address_XML "title"] |
---|
225 | set widget_status "GuiInfo($address-valid)" |
---|
226 | set $widget_status 0 |
---|
227 | |
---|
228 | set part_winactive $path_father.$node_XML |
---|
229 | ttk::label $part_winactive -text "$widget_title ($param_type)" |
---|
230 | pack $part_winactive |
---|
231 | } |
---|
232 | } |
---|
233 | } |
---|
234 | "viewer" { |
---|
235 | set part_winactive [viewer_create -path_father $path_father -address $address] |
---|
236 | } |
---|
237 | default { |
---|
238 | if {$part_class in $additionalWidgets} { |
---|
239 | set part_winactive [$part_class\_create -path_father $path_father -address $address] |
---|
240 | } else { |
---|
241 | debug "part_class Unknown : $part_class ; $address" |
---|
242 | set part_winactive "unknown" |
---|
243 | } |
---|
244 | } |
---|
245 | } |
---|
246 | |
---|
247 | # recursive GUI generation |
---|
248 | |
---|
249 | set GuiInfo($address-children) [dTree_getChildren $XMLtree $full_address_XML] |
---|
250 | |
---|
251 | set sortedChildren "" |
---|
252 | set childrenAndOrder "" |
---|
253 | |
---|
254 | ######## Sort the children according to their "order" attribute |
---|
255 | |
---|
256 | # First, get children and associated orders |
---|
257 | foreach child $GuiInfo($address-children) { |
---|
258 | set order "0" |
---|
259 | set childAndOrder "" |
---|
260 | # Retrieve order from attributes of the child |
---|
261 | set order [dTree_tryGetAttribute $XMLtree "$full_address_XML $child" order "9999"] |
---|
262 | lappend childAndOrder $order |
---|
263 | lappend childAndOrder $child |
---|
264 | lappend childrenAndOrder $childAndOrder |
---|
265 | } |
---|
266 | |
---|
267 | # Then, sort |
---|
268 | set childrenAndOrder [lsort -index 0 -integer $childrenAndOrder] |
---|
269 | |
---|
270 | # Finally, store them |
---|
271 | foreach child $childrenAndOrder { |
---|
272 | lappend sortedChildren [lindex $child 1] |
---|
273 | } |
---|
274 | |
---|
275 | set GuiInfo($address-children) $sortedChildren |
---|
276 | |
---|
277 | if {$part_class != "xor" && $part_class != "multiple" && $part_class != "choice"} { |
---|
278 | foreach child $GuiInfo($address-children) { |
---|
279 | # Case of ";" type nodes (options) |
---|
280 | if {[string match "*;*" $child]} { |
---|
281 | set XML_node_address_child "$full_address_XML \{$child\}" |
---|
282 | } else { |
---|
283 | set XML_node_address_child [concat $full_address_XML $child] |
---|
284 | } |
---|
285 | |
---|
286 | if {[catch {set widget_child_class "[dTree_getAttribute $XMLtree $XML_node_address_child nodeType]"}]} { |
---|
287 | warning "WARNING : $XML_node_address_child doesn't have a node type ...\n Setting it to container ..." |
---|
288 | set widget_child_class "container" |
---|
289 | } |
---|
290 | gui_addpart -address $address.$child -path_father $part_winactive -class $widget_child_class |
---|
291 | } |
---|
292 | } |
---|
293 | |
---|
294 | |
---|
295 | return $part_winactive |
---|
296 | } |
---|
297 | |
---|
298 | |
---|
299 | |
---|
300 | |
---|
301 | proc gui_destroy {win} { |
---|
302 | global GuiInfo |
---|
303 | foreach item [array names GuiInfo "$win-*"] { |
---|
304 | unset GuiInfo($item) |
---|
305 | } |
---|
306 | } |
---|
307 | |
---|
308 | |
---|
309 | |
---|
310 | # Copyright CERFACS 2014 |
---|
311 | # |
---|
312 | # antoine.dauptain@cerfacs.fr |
---|
313 | # |
---|
314 | # This software is a computer program whose purpose is to ensure technology |
---|
315 | # transfer between academia and industry. |
---|
316 | # |
---|
317 | # This software is governed by the CeCILL-B license under French law and |
---|
318 | # abiding by the rules of distribution of free software. You can use, |
---|
319 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
---|
320 | # license as circulated by CEA, CNRS and INRIA at the following URL |
---|
321 | # "http://www.cecill.info". |
---|
322 | # |
---|
323 | # As a counterpart to the access to the source code and rights to copy, |
---|
324 | # modify and redistribute granted by the license, users are provided only |
---|
325 | # with a limited warranty and the software's author, the holder of the |
---|
326 | # economic rights, and the successive licensors have only limited |
---|
327 | # liability. |
---|
328 | # |
---|
329 | # In this respect, the user's attention is drawn to the risks associated |
---|
330 | # with loading, using, modifying and/or developing or reproducing the |
---|
331 | # software by the user in light of its specific status of free software, |
---|
332 | # that may mean that it is complicated to manipulate, and that also |
---|
333 | # therefore means that it is reserved for developers and experienced |
---|
334 | # professionals having in-depth computer knowledge. Users are therefore |
---|
335 | # encouraged to load and test the software's suitability as regards their |
---|
336 | # requirements in conditions enabling the security of their systems and/or |
---|
337 | # data to be ensured and, more generally, to use and operate it in the |
---|
338 | # same conditions as regards security. |
---|
339 | # |
---|
340 | # The fact that you are presently reading this means that you have had |
---|
341 | # knowledge of the CeCILL-B license and that you accept its terms. |
---|