| 1 | # This program is under CECILL_B licence. See footer for details. |
|---|
| 2 | |
|---|
| 3 | |
|---|
| 4 | proc smartpacker_getconfig {} { |
|---|
| 5 | global widgetInfo |
|---|
| 6 | set guiMode [getConfig "config gui appearance mode"] |
|---|
| 7 | if {$guiMode == ""} { |
|---|
| 8 | set guiMode "treeview" |
|---|
| 9 | } |
|---|
| 10 | set guiWidth [getConfig "config gui appearance width"] |
|---|
| 11 | if {$guiWidth == ""} { |
|---|
| 12 | set guiWidth "700" |
|---|
| 13 | } |
|---|
| 14 | set guiHeight [getConfig "config gui appearance height"] |
|---|
| 15 | if {$guiHeight == ""} { |
|---|
| 16 | set guiHeight "700" |
|---|
| 17 | } |
|---|
| 18 | |
|---|
| 19 | set widgetInfo(guimode) $guiMode |
|---|
| 20 | set widgetInfo(guiheight) $guiHeight |
|---|
| 21 | set widgetInfo(guiwidth) $guiWidth |
|---|
| 22 | switch $widgetInfo(guimode) { |
|---|
| 23 | "multicolumn" { |
|---|
| 24 | set widgetInfo(guiSmallWidgetWidth) [expr { int ([expr { 0.37*$widgetInfo(guiwidth)}])}] |
|---|
| 25 | set widgetInfo(guiBigWidgetWidth) [expr { int ([expr { 0.74*$widgetInfo(guiwidth)}])}] |
|---|
| 26 | set widgetInfo(guiEntryRelWidth) 0.5 |
|---|
| 27 | } |
|---|
| 28 | "treeview" { |
|---|
| 29 | set widgetInfo(guiSmallWidgetWidth) [expr { int ([expr { 0.6*$widgetInfo(guiwidth)}])}] |
|---|
| 30 | set widgetInfo(guiBigWidgetWidth) [expr { int ([expr { 0.6*$widgetInfo(guiwidth)}])}] |
|---|
| 31 | set widgetInfo(guiEntryRelWidth) 0.33 |
|---|
| 32 | } |
|---|
| 33 | } |
|---|
| 34 | } |
|---|
| 35 | |
|---|
| 36 | |
|---|
| 37 | # called at the start of the application to initiate the window |
|---|
| 38 | |
|---|
| 39 | proc smartpacker_initialize_gui { loadedProject } { |
|---|
| 40 | global widgetInfo |
|---|
| 41 | global workingDir |
|---|
| 42 | switch $widgetInfo(guimode) { |
|---|
| 43 | "multicolumn" { |
|---|
| 44 | # bind the main window to the resizing action |
|---|
| 45 | |
|---|
| 46 | set widgetInfo(SetViewMode) "large" |
|---|
| 47 | event generate . <<SetView>> |
|---|
| 48 | |
|---|
| 49 | |
|---|
| 50 | bind . <Configure> { |
|---|
| 51 | set ActualWidth [winfo width .] |
|---|
| 52 | #puts "AW $ActualWidth" |
|---|
| 53 | #puts "VM $widgetInfo(SetViewMode)" |
|---|
| 54 | |
|---|
| 55 | if {$ActualWidth >[expr { (2.2)*$widgetInfo(guiSmallWidgetWidth)}] && $widgetInfo(SetViewMode)=="small"} { |
|---|
| 56 | set widgetInfo(SetViewMode) "large" |
|---|
| 57 | event generate . <<SetView>> |
|---|
| 58 | } |
|---|
| 59 | if {$ActualWidth >[expr { (3.3)*$widgetInfo(guiSmallWidgetWidth)}] && $widgetInfo(SetViewMode)=="large"} { |
|---|
| 60 | set widgetInfo(SetViewMode) "huge" |
|---|
| 61 | event generate . <<SetView>> |
|---|
| 62 | } |
|---|
| 63 | if {$ActualWidth <[expr { (2.2)*$widgetInfo(guiSmallWidgetWidth)}] && $widgetInfo(SetViewMode)=="large"} { |
|---|
| 64 | set widgetInfo(SetViewMode) "small" |
|---|
| 65 | event generate . <<SetView>> |
|---|
| 66 | } |
|---|
| 67 | if {$ActualWidth <[expr { (3.3)*$widgetInfo(guiSmallWidgetWidth)}] && $widgetInfo(SetViewMode)=="huge"} { |
|---|
| 68 | set widgetInfo(SetViewMode) "large" |
|---|
| 69 | event generate . <<SetView>> |
|---|
| 70 | } |
|---|
| 71 | |
|---|
| 72 | |
|---|
| 73 | } |
|---|
| 74 | } |
|---|
| 75 | "treeview" { |
|---|
| 76 | |
|---|
| 77 | } |
|---|
| 78 | } |
|---|
| 79 | wm geometry . ${widgetInfo(guiwidth)}x${widgetInfo(guiheight)} |
|---|
| 80 | raise . |
|---|
| 81 | |
|---|
| 82 | if {$loadedProject != "none"} { |
|---|
| 83 | loadProject $loadedProject |
|---|
| 84 | } |
|---|
| 85 | update |
|---|
| 86 | } |
|---|
| 87 | |
|---|
| 88 | # correction of focus on mac OSX |
|---|
| 89 | proc smartpacker_focus_correction {} { |
|---|
| 90 | if {[getConfig "config gui appearance focusCorrection"] == 1} { |
|---|
| 91 | bind . <ButtonPress-1> { |
|---|
| 92 | if {[focus] == ""} { |
|---|
| 93 | focus -force [focus -lastfor .] |
|---|
| 94 | } |
|---|
| 95 | } |
|---|
| 96 | } |
|---|
| 97 | event generate . <<InitializeGUI>> |
|---|
| 98 | } |
|---|
| 99 | |
|---|
| 100 | |
|---|
| 101 | # smartpacker algorithm |
|---|
| 102 | proc smartpacker_regrid { } { |
|---|
| 103 | global widgetInfo |
|---|
| 104 | #log "regrid" |
|---|
| 105 | set viewmode $widgetInfo(SetViewMode) |
|---|
| 106 | |
|---|
| 107 | |
|---|
| 108 | if {$widgetInfo(tabfocus) == ""} { |
|---|
| 109 | set $widgetInfo(tabfocus) [lindex $widgetInfo(form_to_update) 0] |
|---|
| 110 | } |
|---|
| 111 | if {$widgetInfo(tabfocus) == ""} {return} |
|---|
| 112 | set win "$widgetInfo(tabfocus).sf.vport.form" |
|---|
| 113 | |
|---|
| 114 | switch $widgetInfo(guimode) { |
|---|
| 115 | "multicolumn" { |
|---|
| 116 | #incr widgetInfo(nregrid) |
|---|
| 117 | #puts "Regridding... $widgetInfo(nregrid) \n mode $viewmode" |
|---|
| 118 | |
|---|
| 119 | set ColumnSize [expr { 1.1*$widgetInfo(guiSmallWidgetWidth)}] |
|---|
| 120 | set VerticalPad 15 |
|---|
| 121 | set HorizontalPad [expr { 0.001*$widgetInfo(guiSmallWidgetWidth)}] |
|---|
| 122 | set VerticalStart 5 |
|---|
| 123 | set HorizontalStart 5 |
|---|
| 124 | |
|---|
| 125 | # get the number of columns |
|---|
| 126 | switch $viewmode { |
|---|
| 127 | "small" { |
|---|
| 128 | set colmax 1 |
|---|
| 129 | } |
|---|
| 130 | "large" { |
|---|
| 131 | set colmax 2 |
|---|
| 132 | } |
|---|
| 133 | "huge" { |
|---|
| 134 | set colmax 3 |
|---|
| 135 | } |
|---|
| 136 | default { |
|---|
| 137 | set colmax 1 |
|---|
| 138 | } |
|---|
| 139 | } |
|---|
| 140 | |
|---|
| 141 | update idletasks |
|---|
| 142 | |
|---|
| 143 | #list of widget to repack |
|---|
| 144 | set widgetlist "" |
|---|
| 145 | foreach wc [winfo children $win] { |
|---|
| 146 | if {[ winfo manager $wc ] != ""} { |
|---|
| 147 | lappend widgetlist $wc |
|---|
| 148 | } |
|---|
| 149 | } |
|---|
| 150 | |
|---|
| 151 | # 1st loop on widgets to fill info and depack widgets |
|---|
| 152 | set wp(narrow-height) 0 |
|---|
| 153 | set wp(narrow-list) "" |
|---|
| 154 | set wp(wide-list) "" |
|---|
| 155 | foreach widget $widgetlist { |
|---|
| 156 | eval $widgetInfo(unpackme-$widget) |
|---|
| 157 | |
|---|
| 158 | pack $widget |
|---|
| 159 | |
|---|
| 160 | set wp($widget-height) [winfo reqheight $widget] |
|---|
| 161 | if {$wp($widget-height) == 0 } {set wp($widget-height) [winfo height $widget]} |
|---|
| 162 | set wp($widget-width) [winfo reqwidth $widget] |
|---|
| 163 | if {$wp($widget-width) == 0 } {set wp($widget-width) [winfo width $widget]} |
|---|
| 164 | |
|---|
| 165 | pack forget $widget |
|---|
| 166 | |
|---|
| 167 | |
|---|
| 168 | |
|---|
| 169 | if {$wp($widget-width) < $ColumnSize} { |
|---|
| 170 | incr wp(narrow-height) $wp($widget-height) |
|---|
| 171 | lappend wp(narrow-list) $widget |
|---|
| 172 | } else { |
|---|
| 173 | lappend wp(wide-list) $widget |
|---|
| 174 | } |
|---|
| 175 | |
|---|
| 176 | } |
|---|
| 177 | |
|---|
| 178 | |
|---|
| 179 | set vmax 0 |
|---|
| 180 | set hmax 0 |
|---|
| 181 | # balance the columns |
|---|
| 182 | # if the middle of the widget is below the maximum average, |
|---|
| 183 | # then the widget must jump one col |
|---|
| 184 | set max [expr {int($wp(narrow-height)/$colmax*1.0)}] |
|---|
| 185 | set position 0 |
|---|
| 186 | set mid_position 0 |
|---|
| 187 | set jumpwidget 0 |
|---|
| 188 | set sparecolumns $colmax |
|---|
| 189 | |
|---|
| 190 | foreach widget $wp(narrow-list) { |
|---|
| 191 | set mid_position [ expr {int($position+ int(0.5*$wp($widget-height)))}] |
|---|
| 192 | if { $mid_position > $max && $sparecolumns > 1 } { |
|---|
| 193 | set position 0 |
|---|
| 194 | set wp($widget-jump) 1 |
|---|
| 195 | incr sparecolumns -1 |
|---|
| 196 | } else { |
|---|
| 197 | set wp($widget-jump) 0 |
|---|
| 198 | } |
|---|
| 199 | incr position $wp($widget-height) |
|---|
| 200 | } |
|---|
| 201 | |
|---|
| 202 | |
|---|
| 203 | # loop on narrow widgets |
|---|
| 204 | set wp(x1) $HorizontalStart |
|---|
| 205 | set wp(y1) $VerticalStart |
|---|
| 206 | set wp(narrowtotalheight) 0 |
|---|
| 207 | foreach widget $wp(narrow-list) { |
|---|
| 208 | if {$wp($widget-jump)} { |
|---|
| 209 | set wp(x1) [expr {int($wp(x1) + $HorizontalPad + $ColumnSize)}] |
|---|
| 210 | set wp(y1) $VerticalStart |
|---|
| 211 | } |
|---|
| 212 | place $widget -x $wp(x1) -y $wp(y1) -width $wp($widget-width) -height $wp($widget-height) |
|---|
| 213 | set widgetInfo(packme-$widget) [subst { |
|---|
| 214 | set widgetInfo(fixedview) 1 |
|---|
| 215 | place $widget -x $wp(x1) -y $wp(y1) -width $wp($widget-width) -height $wp($widget-height) |
|---|
| 216 | event generate . <<SetView>> |
|---|
| 217 | set widgetInfo(fixedview) 0 |
|---|
| 218 | }] |
|---|
| 219 | set widgetInfo(unpackme-$widget) [subst { |
|---|
| 220 | place forget $widget |
|---|
| 221 | }] |
|---|
| 222 | |
|---|
| 223 | |
|---|
| 224 | |
|---|
| 225 | incr wp(y1) $wp($widget-height) |
|---|
| 226 | incr wp(y1) $VerticalPad |
|---|
| 227 | if { $wp(narrowtotalheight) < $wp(y1) } { set wp(narrowtotalheight) $wp(y1)} |
|---|
| 228 | } |
|---|
| 229 | set hmax [expr {int($wp(x1) + $HorizontalPad + $ColumnSize)}] |
|---|
| 230 | |
|---|
| 231 | |
|---|
| 232 | #loop on wide widgets |
|---|
| 233 | set wp(x1) $HorizontalStart |
|---|
| 234 | set wp(y1) $wp(narrowtotalheight) |
|---|
| 235 | foreach widget $wp(wide-list) { |
|---|
| 236 | place $widget -x $wp(x1) -y $wp(y1) -width $wp($widget-width) -height $wp($widget-height) |
|---|
| 237 | set widgetInfo(packme-$widget) [subst { |
|---|
| 238 | set widgetInfo(fixedview) 1 |
|---|
| 239 | place $widget -x $wp(x1) -y $wp(y1) -width $wp($widget-width) -height $wp($widget-height) |
|---|
| 240 | event generate . <<SetView>> |
|---|
| 241 | set widgetInfo(fixedview) 0 |
|---|
| 242 | }] |
|---|
| 243 | set widgetInfo(unpackme-$widget) [subst { |
|---|
| 244 | place forget $widget |
|---|
| 245 | }] |
|---|
| 246 | |
|---|
| 247 | incr wp(y1) $wp($widget-height) |
|---|
| 248 | incr wp(y1) 5 |
|---|
| 249 | set widthwide [expr {int($wp($widget-width) +$HorizontalStart+2*$HorizontalPad)}] |
|---|
| 250 | if { $widthwide > $hmax} {set hmax $widthwide} |
|---|
| 251 | |
|---|
| 252 | } |
|---|
| 253 | set vmax $wp(y1) |
|---|
| 254 | |
|---|
| 255 | |
|---|
| 256 | # clean all variables used |
|---|
| 257 | array unset wp |
|---|
| 258 | |
|---|
| 259 | # adjust the form |
|---|
| 260 | $win configure -width $hmax -height $vmax |
|---|
| 261 | set widgetInfo(ReGrid) "no" |
|---|
| 262 | |
|---|
| 263 | scrollform_resize [crop_address $win 2] |
|---|
| 264 | |
|---|
| 265 | |
|---|
| 266 | |
|---|
| 267 | |
|---|
| 268 | } |
|---|
| 269 | "treeview" { |
|---|
| 270 | |
|---|
| 271 | } |
|---|
| 272 | |
|---|
| 273 | } |
|---|
| 274 | |
|---|
| 275 | |
|---|
| 276 | |
|---|
| 277 | } |
|---|
| 278 | |
|---|
| 279 | |
|---|
| 280 | proc smartpacker_update_visibility { win address } { |
|---|
| 281 | global widgetInfo |
|---|
| 282 | if {$widgetInfo($address-existIf)} { |
|---|
| 283 | if {$widgetInfo($address-visible)} { |
|---|
| 284 | eval $widgetInfo(packme-$win) |
|---|
| 285 | } else { |
|---|
| 286 | #debug "unpackme $win" |
|---|
| 287 | eval $widgetInfo(unpackme-$win) |
|---|
| 288 | } |
|---|
| 289 | } |
|---|
| 290 | } |
|---|
| 291 | |
|---|
| 292 | # called when a modelframe is initiated, to keep the same layout for each frame |
|---|
| 293 | proc smartpacker_setup_modelframe { win address } { |
|---|
| 294 | uplevel 1 {} { |
|---|
| 295 | |
|---|
| 296 | set title [dTree_getAttribute $XMLtree $full_address_XML "title"] |
|---|
| 297 | |
|---|
| 298 | # main labelframe or frame in flat-style |
|---|
| 299 | switch -glob $style { |
|---|
| 300 | "flat" { |
|---|
| 301 | ttk::frame $win |
|---|
| 302 | } |
|---|
| 303 | "group_of_models" { |
|---|
| 304 | ttk::frame $win |
|---|
| 305 | ttk::label $win.title -text $title -style "Model.TLabelframe.Label" |
|---|
| 306 | ttk::separator $win.sep -orient horizontal |
|---|
| 307 | pack $win.title -side top |
|---|
| 308 | pack $win.sep -side top -fill x |
|---|
| 309 | |
|---|
| 310 | } |
|---|
| 311 | |
|---|
| 312 | "onrequest" { |
|---|
| 313 | set widgetInfo($address-onrequest) 0 |
|---|
| 314 | ttk::frame $win |
|---|
| 315 | |
|---|
| 316 | ttk::label $win.title -image icon_plus -compound left -text $title |
|---|
| 317 | |
|---|
| 318 | |
|---|
| 319 | ttk::separator $win.sep -orient horizontal |
|---|
| 320 | pack $win.title -side top -anchor w |
|---|
| 321 | pack $win.sep -side top -fill x |
|---|
| 322 | ttk::frame $win.snap |
|---|
| 323 | bind $win.title <ButtonPress> [subst { |
|---|
| 324 | if {\$widgetInfo($address-onrequest) == 0} { |
|---|
| 325 | set widgetInfo($address-onrequest) 1 |
|---|
| 326 | pack $win.snap -side top -fill both |
|---|
| 327 | $win.title configure -image icon_minus |
|---|
| 328 | event generate . <<SetView>> |
|---|
| 329 | } else { |
|---|
| 330 | set widgetInfo($address-onrequest) 0 |
|---|
| 331 | pack forget $win.snap |
|---|
| 332 | $win.title configure -image icon_plus |
|---|
| 333 | event generate . <<SetView>> |
|---|
| 334 | } |
|---|
| 335 | }] |
|---|
| 336 | } |
|---|
| 337 | "sublevel_*" { |
|---|
| 338 | set level [lindex [split $style "_" ] 1] |
|---|
| 339 | |
|---|
| 340 | if {$level < 1} {set level 1} |
|---|
| 341 | if {$level > 3} {set level 3} |
|---|
| 342 | set pad [expr { $level *20}] |
|---|
| 343 | ttk::frame $win |
|---|
| 344 | label $win.title -text $title -image "bullet_$level" -compound left -bg [ThemeColor 1.0] -fg [ThemeColor [expr {$level*0.2}]] |
|---|
| 345 | #-style "Model.TLabelframe.Label" |
|---|
| 346 | ttk::separator $win.sep -orient vertical |
|---|
| 347 | pack $win.sep -side left -fill y -padx "$pad 0" -pady 10 |
|---|
| 348 | |
|---|
| 349 | |
|---|
| 350 | |
|---|
| 351 | pack $win.title -side top -anchor w |
|---|
| 352 | |
|---|
| 353 | } |
|---|
| 354 | default { |
|---|
| 355 | ttk::labelframe $win -text $title -style "Model.TLabelframe" |
|---|
| 356 | } |
|---|
| 357 | } |
|---|
| 358 | |
|---|
| 359 | eval $widgetInfo(packme-$win) |
|---|
| 360 | |
|---|
| 361 | ttk::frame $win.forceps -width $widgetInfo(guiSmallWidgetWidth) -height 0 |
|---|
| 362 | pack $win.forceps -side top |
|---|
| 363 | } |
|---|
| 364 | } |
|---|
| 365 | |
|---|
| 366 | # called when a simple widget is initiated, to keep the same label layout for each simple widget |
|---|
| 367 | proc smartpacker_setup_label { win address } { |
|---|
| 368 | uplevel 1 {} { |
|---|
| 369 | set title "[dTree_getAttribute $XMLtree $full_address_XML "title"]:" |
|---|
| 370 | ttk::label $win.lbl -text $title -justify right |
|---|
| 371 | |
|---|
| 372 | if { $widgetInfo(guimode) == "multicolumn"} { |
|---|
| 373 | $win.lbl configure -wraplength [expr { int(0.5*$widgetInfo(guiSmallWidgetWidth))}] |
|---|
| 374 | } |
|---|
| 375 | |
|---|
| 376 | place $win.lbl -relx 0.5 -rely 0. -anchor ne |
|---|
| 377 | } |
|---|
| 378 | } |
|---|
| 379 | |
|---|
| 380 | # called when a widget is initiated, to keep the same status layout for each simple widget |
|---|
| 381 | proc smartpacker_setup_status { win address } { |
|---|
| 382 | uplevel 1 {} { |
|---|
| 383 | set widgetInfo($address-status) 0 |
|---|
| 384 | set widgetInfo($address-status_txt) "" |
|---|
| 385 | ttk::label $win.status -textvariable widgetInfo($address-status_txt) -foreground "red" -justify center -compound left |
|---|
| 386 | $win.status configure -wraplength [expr { 0.6*$widgetInfo(guiSmallWidgetWidth)}] |
|---|
| 387 | place $win.status -relx 0.5 -rely 1 -anchor s |
|---|
| 388 | } |
|---|
| 389 | } |
|---|
| 390 | |
|---|
| 391 | |
|---|
| 392 | proc Start_think { cmd} { |
|---|
| 393 | global abort_cmd |
|---|
| 394 | |
|---|
| 395 | set abort_cmd $cmd |
|---|
| 396 | |
|---|
| 397 | . config -cursor watch |
|---|
| 398 | grab .log |
|---|
| 399 | update |
|---|
| 400 | } |
|---|
| 401 | |
|---|
| 402 | proc Stop_think { mode } { |
|---|
| 403 | global abort_cmd |
|---|
| 404 | . config -cursor left_ptr |
|---|
| 405 | grab release .log |
|---|
| 406 | raise . |
|---|
| 407 | if {$abort_cmd == ""} {set mode "normal"} |
|---|
| 408 | switch $mode { |
|---|
| 409 | "normal" { |
|---|
| 410 | |
|---|
| 411 | } |
|---|
| 412 | "abort" { |
|---|
| 413 | warning "Aborting ..." |
|---|
| 414 | eval $abort_cmd |
|---|
| 415 | } |
|---|
| 416 | default { |
|---|
| 417 | error "Wrong use of stop_think" |
|---|
| 418 | } |
|---|
| 419 | } |
|---|
| 420 | update |
|---|
| 421 | } |
|---|
| 422 | |
|---|
| 423 | |
|---|
| 424 | |
|---|
| 425 | # Copyright CERFACS 2014 |
|---|
| 426 | # |
|---|
| 427 | # antoine.dauptain@cerfacs.fr |
|---|
| 428 | # |
|---|
| 429 | # This software is a computer program whose purpose is to ensure technology |
|---|
| 430 | # transfer between academia and industry. |
|---|
| 431 | # |
|---|
| 432 | # This software is governed by the CeCILL-B license under French law and |
|---|
| 433 | # abiding by the rules of distribution of free software. You can use, |
|---|
| 434 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
|---|
| 435 | # license as circulated by CEA, CNRS and INRIA at the following URL |
|---|
| 436 | # "http://www.cecill.info". |
|---|
| 437 | # |
|---|
| 438 | # As a counterpart to the access to the source code and rights to copy, |
|---|
| 439 | # modify and redistribute granted by the license, users are provided only |
|---|
| 440 | # with a limited warranty and the software's author, the holder of the |
|---|
| 441 | # economic rights, and the successive licensors have only limited |
|---|
| 442 | # liability. |
|---|
| 443 | # |
|---|
| 444 | # In this respect, the user's attention is drawn to the risks associated |
|---|
| 445 | # with loading, using, modifying and/or developing or reproducing the |
|---|
| 446 | # software by the user in light of its specific status of free software, |
|---|
| 447 | # that may mean that it is complicated to manipulate, and that also |
|---|
| 448 | # therefore means that it is reserved for developers and experienced |
|---|
| 449 | # professionals having in-depth computer knowledge. Users are therefore |
|---|
| 450 | # encouraged to load and test the software's suitability as regards their |
|---|
| 451 | # requirements in conditions enabling the security of their systems and/or |
|---|
| 452 | # data to be ensured and, more generally, to use and operate it in the |
|---|
| 453 | # same conditions as regards security. |
|---|
| 454 | # |
|---|
| 455 | # The fact that you are presently reading this means that you have had |
|---|
| 456 | # knowledge of the CeCILL-B license and that you accept its terms. |
|---|
