source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/util/oasisgui/opentea/create_comparator.tcl @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 4 years ago
  • Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from ​https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818
File size: 14.6 KB
Line 
1#  This program is under CECILL_B licence. See footer for details.
2
3
4
5
6# COMPARATOR CREATION
7
8proc comparator_create { args } {
9    set mandatory_arguments { path_father address }
10   
11    # Initializes the widget
12    initWidget 
13   
14    set widgetInfo($address-status) 0
15    set widgetInfo($address-boxsize) 15
16    set widgetInfo($address-statustxt) ""
17    set title [dTree_getAttribute $XMLtree $full_address_XML "title"]   
18    set widgetInfo($address-folder)  [dTree_getAttribute $XMLtree $full_address_XML "folder"]
19    ttk::labelframe $win -text "$title" 
20    eval $widgetInfo(packme-$win)
21   
22   
23    #ttk::label $win.lb -text "$title"
24    #grid $win.lb -column 0 -row 0 -sticky news
25   
26   
27    #frame for picker
28    ttk::frame $win.t 
29   
30 
31   
32    # size of widget
33    set size_v [expr 0.3*$widgetInfo(guiBigWidgetWidth)]
34    set size_h [expr 0.3*$widgetInfo(guiBigWidgetWidth)]
35    canvas $win.t.can -background [ThemeColor 1.0]  -highlightthickness 1 -highlightbackground [ThemeColor 0.5] -yscrollcommand [list $win.t.sby set] -xscrollcommand [list $win.t.sbx set]   -width $size_h -height $size_v 
36    ttk::scrollbar $win.t.sby -orient vertical -command [list $win.t.can yview]
37    ttk::scrollbar $win.t.sbx -orient horizontal -command [list $win.t.can xview]
38    grid $win.t.can -row 1 -column 0 -sticky news
39   
40   
41   
42    # frame for graphs   
43    ttk::frame $win.gr
44    #pack $win.gr -side top -pady {0 5}
45   
46    set size_v [expr 0.3*$widgetInfo(guiBigWidgetWidth)]
47    set size_h [expr 0.8*$widgetInfo(guiBigWidgetWidth)]   
48    canvas $win.gr.can  -background [ThemeColor 1.0]  -highlightthickness 1 -highlightbackground [ThemeColor 0.5] -yscrollcommand [list $win.gr.sby set] -xscrollcommand [list $win.gr.sbx set]   -width $size_h -height $size_v
49    ttk::scrollbar $win.gr.sby -orient vertical -command [list $win.gr.can yview]
50    ttk::scrollbar $win.gr.sbx -orient horizontal -command [list $win.gr.can xview]
51   
52    ttk::frame $win.gr.c
53    ttk::button $win.gr.c.zoomplus -image icon_magnifierplus -command [subst {grapher_zoom $win.gr.can  1.1}]
54    ttk::button $win.gr.c.zoomminus -image icon_magnifierminus -command [subst {grapher_zoom $win.gr.can  0.9}]
55    ttk::button $win.gr.c.dump -text "Dump" -command [subst {comparator_dump $win $address }]
56    ttk::label $win.gr.c.statustxt -textvariable widgetInfo($address-statustxt) -compound left
57    pack $win.gr.c.zoomplus -side left
58    pack $win.gr.c.zoomminus -side left
59    pack $win.gr.c.dump -side left
60    pack $win.gr.c.statustxt -side left
61   
62   
63   
64    grid $win.gr.can -row 1 -column 0 -sticky news
65    #grid $win.gr.sby -row 1 -column 1 -sticky ns
66    #grid $win.gr.sbx -row 2 -column 0 -sticky ew
67    grid $win.gr.c -row 3 -column 0 -sticky ew
68   
69 
70   
71     # frame for treeview   
72    ttk::frame $win.tv
73
74   
75    ttk::treeview $win.tv.tv  -yscrollcommand [list $win.tv.sby set] -columns "lvalue rvalue" -height 8
76    $win.tv.tv column #0 -width [expr {int(0.3*$widgetInfo(guiBigWidgetWidth))}]
77    $win.tv.tv column 0 -width [expr {int(0.4*$widgetInfo(guiBigWidgetWidth))}]
78    $win.tv.tv column 1 -width [expr {int(0.4*$widgetInfo(guiBigWidgetWidth))}]
79   
80   
81    #$win.tv.tv insert {} 0 -id "dataset" -text "." -open "true"
82   
83    ttk::scrollbar $win.tv.sby -orient vertical -command [list $win.tv.tv yview]
84   
85   
86   
87   
88    grid $win.tv.tv -row 1 -column 0 -sticky news
89    grid $win.tv.sby -row 1 -column 1 -sticky ns
90 
91
92   
93    grid $win.t  -column 0 -row 0 -sticky news
94    grid $win.gr -column 1 -row 0  -sticky news
95    grid $win.tv -column 0 -row 1 -sticky news -columnspan 2
96   
97   
98   
99    #add the check/refresh procedure to the bindings of the variable
100    append widgetInfo($address-refresh) [ subst { comparator_refresh $win $address}]
101    append widgetInfo($address-check) [subst { comparator_check $win $address}]
102   
103    finishWidget
104   
105    #trick?
106    #bind $win.t.can <ButtonPress-1> {+; focus %W}
107    bind $win.t.can <Motion> [subst {comparator_showlocation $win  $address}]   
108    #  scroll
109    bind $win.t.can   <ButtonPress> [subst {$win.t.can scan mark %x %y}]
110    bind $win.t.can   <B1-Motion> [subst {$win.t.can scan dragto %x %y 1}]
111   
112   
113    # clean the widget callBack on dstruction
114    bind $win <Destroy> [ subst {widget_destroy $win $address}]
115   
116    return $win
117}
118
119proc comparator_refresh {win address} {
120    global widgetInfo
121    comparator_update $win $address
122}
123
124proc comparator_update {win address} {
125    global widgetInfo
126   
127    $win.t.can delete all
128   
129    set list_runs  $widgetInfo($address-requiredValue) 
130
131    # remove selected comparisons from the variable if this run is no more available
132    set current_variable [split $widgetInfo($address-variable) ";"]
133    foreach selectedpair $current_variable {
134        set run1 [lindex [split $selectedpair "@"] 0]
135        set run2 [lindex [split $selectedpair "@"] 1]
136        if {[lsearch $list_runs $run1 ] == -1 } {
137            set current_variable [lremove current_variable $selectedpair]
138        } elseif {[lsearch $list_runs $run2 ]==-1} {
139            set current_variable [lremove current_variable $selectedpair]
140        }
141    }
142   
143    set boxsize $widgetInfo($address-boxsize)
144   
145    #title up
146    set col 0
147    foreach run $list_runs {
148        set title_x [expr { $boxsize*(0.5+$col)}]
149        set title_y [expr { $boxsize*(-0.0)}]
150        set run_sim [lindex [split $run "#"] 0]
151        set run_proj [lindex [split $run "#"] 1]
152        set run_run [lindex [split $run "#"] 2]
153        canvas_text_vector $win.t.can  $title_x $title_y "$run_proj $run_run" sw 8 -45 [comparator_getcolor $run_sim] titleup
154        incr col
155    }
156    #title left
157    set col 0
158    foreach run $list_runs {
159        set title_x [expr { $boxsize*(-0.2+$col)}]
160        set title_y [expr { $boxsize*(0.2+$col)}]
161        set run_sim [lindex [split $run "#"] 0]
162        set run_proj [lindex [split $run "#"] 1]
163        set run_run [lindex [split $run "#"] 2]
164        canvas_text_vector $win.t.can $title_x $title_y "$run_proj $run_run" nw 8 0 [comparator_getcolor $run_sim] titleup
165        incr col
166    }
167   
168    set row 0
169    set col 0
170    foreach run1 $list_runs {
171        foreach run2 $list_runs {
172            set run1_sim [lindex [split $run1 "#"] 0]
173            set run2_sim [lindex [split $run2 "#"] 0]
174            set run1_proj [lindex [split $run1 "#"] 1]
175            set run2_proj [lindex [split $run2 "#"] 1]
176            set run1_run [lindex [split $run1 "#"] 2]
177            set run2_run [lindex [split $run2 "#"] 2]
178            if  {$col >= $row} {
179                 if {$col == $row } {
180                    set shade 0.0
181                 } elseif {$run1_sim == $run2_sim} {
182                    set shade 0.5
183                 } else {
184                    set shade 0.75
185                 }
186                 
187                set couple "$run1@$run2"
188                # ul_x--------------
189                # ul_y             |
190                # |                |
191                # |  ul2_x---|     |
192                # |  ul2_Y   |     |
193                # |  |       |     |
194                # |  |      lr2_x  |
195                # |  |------lr2_y  |
196                # |                |
197                # |                |
198                # |             lr_x
199                # |-------------lr_y
200                set ul_x [expr {$col*$boxsize}]
201                set ul_y [expr {$row*$boxsize}]
202   
203                set lr_x [expr {$ul_x+$boxsize}]
204                set lr_y [expr {$ul_y+$boxsize}]
205               
206                set ul2_x [expr {($col+0.2)*$boxsize}]
207                set ul2_y [expr {($row+0.2)*$boxsize}]
208   
209                set lr2_x [expr {$ul_x+0.8*$boxsize}]
210                set lr2_y [expr {$ul_y+0.8*$boxsize}]
211               
212                $win.t.can create polygon $ul_x $ul_y $ul_x $lr_y $lr_x $lr_y $ul_x $ul_y -fill [shadeColor [comparator_getcolor $run1_sim] $shade] -tags "$couple"
213                $win.t.can create polygon $ul_x $ul_y $lr_x $ul_y $lr_x $lr_y $ul_x $ul_y -fill [shadeColor [comparator_getcolor $run2_sim] $shade] -tags "$couple"
214                $win.t.can create line $ul_x $ul_y $lr_x $ul_y $lr_x $lr_y $ul_x $lr_y  $ul_x $ul_y -fill black
215               
216                if {[lsearch $current_variable $couple] != -1} {
217                    $win.t.can create oval $ul2_x $ul2_y  $lr2_x $lr2_y  -outline white -width 2 -tags "$couple"
218                }
219                $win.t.can bind $couple <ButtonPress> [subst {comparator_clickrun $win $address $couple}]
220            }
221            incr col
222        }
223        set col 0
224        incr row
225    }
226   
227    set widgetInfo($address-status) 0
228    set widgetInfo($address-statustxt) "Comparisons data need to be dumped..."
229    $win.gr.c.statustxt configure -image icon_question
230   
231    $win.t.can configure -scrollregion [ $win.t.can bbox all]
232   
233    smartpacker_update_visibility $win $address
234   
235   
236    set widgetInfo($address-variable) [join $current_variable ";"]
237}
238
239proc comparator_clickrun {win address selectedpair} {
240    global widgetInfo
241   
242   
243    set current_variable [split $widgetInfo($address-variable) ";"]
244    $win.gr.can delete all
245    if {[lsearch $current_variable $selectedpair] != -1 } {
246        # remove a comparison
247        set current_variable [lremove current_variable $selectedpair]
248        set file1   [ lindex [ split $selectedpair "@"] 0 ]
249        set file2   [ lindex [ split $selectedpair "@"] 1 ] 
250        #debug "Removes $file1 $file2"
251       
252        #$win.tx.txt configure -state normal
253        #$win.tx.txt delete 0.0 end
254        #$win.tx.txt configure -state disabled
255       
256       
257    } else {
258        # add a comparison
259        lappend current_variable $selectedpair
260        set file1  [ lindex [ split $selectedpair "@"] 0 ] 
261        set file2  [ lindex [ split $selectedpair "@"] 1 ] 
262        grapher_create $win $address $win.gr.can $win.tv.tv [file join {*}$widgetInfo($address-folder)] "$file1" "$file2" 0
263        #debug "Add  $file1 $file2"
264    }
265   
266    set widgetInfo($address-variable) [join $current_variable ";"]
267   
268    comparator_update $win $address
269   
270    eval $widgetInfo($address-check)
271    return
272}
273
274
275proc comparator_getcolor {sim} {
276    set color "black"
277    switch $sim {
278        "Sim.1" {
279            set color "black"
280        }
281        "Sim.2" {
282            set color "red"
283        }
284        "Sim.3" {
285            set color "blue"
286        }
287        "Sim.4" {
288            set color "green4"
289        } 
290    }
291    return $color
292
293}
294
295proc comparator_dump {win address} {
296    global widgetInfo
297    set current_variable [split $widgetInfo($address-variable) ";"]
298   
299    #cleaning
300    foreach filename [glob -nocomplain [file join {*}$widgetInfo($address-folder) *.gif] ] {
301        file delete -force $filename
302    }
303    foreach filename [glob -nocomplain [file join {*}$widgetInfo($address-folder) *.html] ] {
304        file delete -force $filename
305    }
306    foreach filename [glob -nocomplain [file join {*}$widgetInfo($address-folder) *.txt] ] {
307        file delete -force $filename
308    }
309   
310    # saving comparisons
311    set index 1
312    set items [llength $current_variable]
313    foreach selectedpair $current_variable {
314        set widgetInfo($address-statustxt) "Dumping $index/$items..."
315        update idletasks
316       
317        set file1 [join [ split [ lindex [ split $selectedpair "@"] 0 ] "#" ] "_"]
318        set file2 [join [ split [ lindex [ split $selectedpair "@"] 1 ] "#" ] "_"]
319        grapher_create $win $address $win.gr.can $win.tv.tv [file join {*}$widgetInfo($address-folder)] "$file1" "$file2" 1
320        incr index
321    }
322   
323    # saving selection
324    set widgetInfo($address-statustxt) "Dumping Selection Array..."
325    update idletasks
326    canvas_makegif $win.t.can  [file join {*}$widgetInfo($address-folder) "$widgetInfo($address-name).gif"]
327   
328    set widgetInfo($address-status) 1
329    set widgetInfo($address-statustxt) "Comparisons data are saved!"
330    $win.gr.c.statustxt configure -image icon_ok
331}
332
333proc comparator_showlocation {win address} {
334    global widgetInfo
335    $win.t.can delete "pointer"   
336    set x [$win.t.can canvasx [expr {[winfo pointerx $win.t.can] - [winfo rootx $win.t.can]}]]
337    set y [$win.t.can canvasy [expr {[winfo pointery $win.t.can] - [winfo rooty $win.t.can]}]]
338   
339    if {$x < 0} {return}
340    if {$y < 0} {return}
341   
342    set boxsize $widgetInfo($address-boxsize)
343    set col [expr {int($x*1.0/$boxsize)}]
344    set row [expr {int($y*1.0/$boxsize)}]
345   
346    set maxcol [expr {[llength $widgetInfo($address-requiredValue) ]-1}]
347   
348    if {$col < $row} {return}
349    if {$col > $maxcol} {return}
350    if {$row > $maxcol} {return}
351   
352    set runcol [lindex $widgetInfo($address-requiredValue) $col]
353    set runrow [lindex $widgetInfo($address-requiredValue) $row] 
354    if {$col == $row} {
355        set widgetInfo($address-position) "$runcol"
356    } else {
357        set widgetInfo($address-position) "$runrow \n .vs. \n $runcol "
358    }
359    canvas_text_highlighted $win.t.can $x $y  $widgetInfo($address-position) "pointer" 
360}
361
362
363
364proc comparator_check {win address} {
365    global widgetInfo
366   
367    #canvas_makegif $win.t.can $address "$widgetInfo($address-name).gif"
368   
369}
370
371
372
373
374#  Copyright CERFACS 2014
375#   
376#  antoine.dauptain@cerfacs.fr
377#   
378#  This software is a computer program whose purpose is to ensure technology
379#  transfer between academia and industry.
380#   
381#  This software is governed by the CeCILL-B license under French law and
382#  abiding by the rules of distribution of free software.  You can  use,
383#  modify and/ or redistribute the software under the terms of the CeCILL-B
384#  license as circulated by CEA, CNRS and INRIA at the following URL
385#  "http://www.cecill.info".
386#   
387#  As a counterpart to the access to the source code and  rights to copy,
388#  modify and redistribute granted by the license, users are provided only
389#  with a limited warranty  and the software's author,  the holder of the
390#  economic rights,  and the successive licensors  have only  limited
391#  liability.
392#   
393#  In this respect, the user's attention is drawn to the risks associated
394#  with loading,  using,  modifying and/or developing or reproducing the
395#  software by the user in light of its specific status of free software,
396#  that may mean  that it is complicated to manipulate,  and  that  also
397#  therefore means  that it is reserved for developers  and  experienced
398#  professionals having in-depth computer knowledge. Users are therefore
399#  encouraged to load and test the software's suitability as regards their
400#  requirements in conditions enabling the security of their systems and/or
401#  data to be ensured and,  more generally, to use and operate it in the
402#  same conditions as regards security.
403#   
404#  The fact that you are presently reading this means that you have had
405#  knowledge of the CeCILL-B license and that you accept its terms.
Note: See TracBrowser for help on using the repository browser.