[4775] | 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. |
---|