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

Last change on this file was 4775, checked in by aclsce, 5 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: 37.6 KB
Line 
1#  This program is under CECILL_B licence. See footer for details.
2
3###########################
4# this procedure handles the
5# creation of the main window
6# with the menu at the top
7###########################
8
9proc createWin {win} {
10    global DStree XMLtree debug widgetInfo FunctionUsed FunctionTime loadApplication applicationList topPath relaunchCmd configPath  faqdata loadedProject wrapper
11    wm title . "OpenTEA"
12    wm focusmodel . active   
13    . configure -takefocus 1
14   
15    raise .
16   
17    if {$widgetInfo(classApp) != "nanoapp"} {
18
19        wm protocol . WM_DELETE_WINDOW {quit_gui}   
20        menu .menu
21        menu .menu.file
22   
23        .menu add cascade -menu .menu.file -label "File"
24        .menu.file add command -label "Load as new" -command { loadProject_as_new }
25        .menu.file add command -label "Load as part " -command {Load_XML_File}
26       
27        .menu.file add command -label "Save" -command {Save_XML_File  "save"} -accelerator "ctrl-s"
28        .menu.file add command -label "Save as" -command {Save_XML_File  "save_as"}   
29        .menu.file add separator
30        #.menu.file add command -label "Import CSV" -command {Load_CSV_File}
31        #.menu.file add command -label "Export CSV" -command {Save_CSV_File}
32        .menu.file add separator
33        .menu.file add command -label "Generate help" -command {Window_help_generator}  -accelerator "ctrl-h"
34        .menu.file add command -label "Preferences" -command {Window_preferences}
35        .menu.file add command -label "About  engine" -command {Window_about}
36        .menu.file add separator
37        .menu.file add command -label "Quit" -command {quit_gui} -accelerator "ctrl-q"
38       
39        menu .menu.apps
40        .menu add cascade -menu .menu.apps -label "Applications"
41       
42        set accessibleApplicationList $applicationList
43        lremove accessibleApplicationList config
44        foreach app $applicationList {
45            set cmd "$relaunchCmd -code $app &"
46            set buttonCommand [subst {
47                wm iconify .
48                puts "Executing $cmd"
49                exec $cmd 
50            }]
51            .menu.apps add command -label $app -command $buttonCommand
52        }
53       
54        menu .menu.config
55        .menu add cascade -menu .menu.config -label "Config"
56        set cmd "$relaunchCmd -code config -file $configPath &"
57        .menu.config add command -label "Edit config" -command [subst {
58            puts "Executing $cmd"
59            exec $cmd
60           
61        }]
62       
63        menu .menu.myproject
64            .menu add cascade -menu .menu.myproject -label "FAQ"
65            foreach faqname $faqdata(faqlist) {
66                .menu.myproject add command -label $faqdata($faqname-title) -command [subst {Window_faq $faqname}]
67            }
68        if {$debug} {
69            menu .menu.debug
70            .menu add cascade -menu .menu.debug -label "Debug"
71            .menu.debug add command -label "Show DSTree" -command {Window_DStree .treeviewDS}
72            .menu.debug add command -label "Show tmpTree" -command {Window_tmptree .treeviewtmp}
73            .menu.debug add command -label "Show XMLTree" -command { Window_XMLtree .treeviewXML}
74            .menu.debug add separator
75            .menu.debug add command -label "Console" -command { Window_console }
76            .menu.debug add command -label "Memory" -command { Window_memory }
77            if {$wrapper} {
78                .menu.debug add command -label "Profiling" -command { Window_profiling }
79            } else {
80                .menu.debug add command -label "Profiling" -state disabled
81               
82            }
83            .menu.debug add command -label "Packing" -command { Window_packing }
84            .menu.debug add command -label "functions usage" -command {
85                puts "=============================="
86                puts "       functions usage (function sorted)"
87                puts "=============================="
88                puts ""
89                puts "Function ; number of calls ; time spent (microsec)"
90                set functionList [list]
91                foreach function [lsort [array names FunctionUsed]] {
92                   
93                    set func "$function $FunctionUsed($function) $FunctionTime($function) 0"
94                    if {$FunctionUsed($function) != 0} {
95                        lset func 3 [expr {$FunctionTime($function) / $FunctionUsed($function)}]
96                    }
97                   
98                    lappend functionList $func
99                }
100               
101                foreach function [lsort -index 2 -integer $functionList] {
102                    puts [join $function " ; "]
103                }
104            }
105            .menu.debug add separator
106            .menu.debug add command -label "AutoPython (dev)" -command { genPyFromXMLtree }       
107        }
108       
109        . config -menu .menu
110    }
111}
112
113
114proc quit_gui {} {
115    global loadedProject widgetInfo log_channel
116   
117   
118    set win .quit
119   
120   
121    if {[winfo exists $win]} {
122        wm deiconify $win
123        raise $win
124    } else {
125        toplevel $win
126        wm title $win "Quitting..."
127        wm attributes $win 
128        ttk::frame $win.f 
129        pack $win.f -expand 1
130       
131       
132        set wif $win.f
133       
134       
135       
136        ttk::label $wif.icon -image icon_gui_small
137        grid $wif.icon  -column 1 -row 0 -pady 5
138       
139       
140       
141        # QUIT WOS
142        ttk::frame $wif.quitwos
143        grid  $wif.quitwos -column 1 -row 1 -pady 5
144            ttk::button $wif.quitwos.butt -text "Quit without saving" -command [subst {
145                log  "Quitting  - without saving -"
146                close $log_channel
147                exit
148            }]
149            pack $wif.quitwos.butt -side top -pady 5
150            ttk::label $wif.quitwos.label -wraplength  $widgetInfo(guiSmallWidgetWidth) -text "Brutal quit : if you did some actions since the last save, the GUI will forget them, BUT the files generated will not revert back to the last saved state."
151            pack $wif.quitwos.label -side top -pady 5
152           
153       
154        # CANCEL       
155        ttk::frame $wif.cancel
156        grid  $wif.cancel -column 1 -row 2 -pady 5 
157           
158            ttk::button $wif.cancel.butt -text "Cancel" -command [subst {
159                destroy $win
160                raise .
161                focus .
162            }]
163            pack $wif.cancel.butt -side top -pady 5
164            ttk::label $wif.cancel.label -wraplength  $widgetInfo(guiSmallWidgetWidth) -text "Go back to main GUI. Never mind."
165            pack $wif.cancel.label -side top -pady 20
166       
167       
168        # SAVE ONLY_GREEN   
169        ttk::frame $wif.savegreen
170        grid  $wif.savegreen -column 1 -row 3 -pady 5
171       
172            ttk::button $wif.savegreen.butt -text "Save only green tabs" -command [subst {
173                Save_XML_File "save" "greenonly" 
174                log  "Quitting  - green only -"
175                close $log_channel
176                exit
177            }]
178            pack $wif.savegreen.butt -side top -pady 5
179       
180            ttk::label $wif.savegreen.label  -wraplength  $widgetInfo(guiSmallWidgetWidth) -text   "only green tabs : only the validated tabs (green icon) will be saved, to avoid the storage of incoherences or spurious data." 
181            pack $wif.savegreen.label -side top -pady 5
182           
183            ttk::label $wif.savegreen.l1 -image icon_ok
184            pack $wif.savegreen.l1 -side left -pady 5
185       
186       
187           
188        # SAVE ALL
189        ttk::frame $wif.saveall
190        grid $wif.saveall -column 1 -row 4 -pady 5
191            ttk::button $wif.saveall.butt -text "Save all" -command [subst {
192                Save_XML_File "save" "all"
193                log  "Quitting  - all -"
194                close $log_channel
195                exit
196            }]
197            pack $wif.saveall.butt -side top -pady 5
198            ttk::label $wif.saveall.label -wraplength  $widgetInfo(guiSmallWidgetWidth) -text "all (Ctrl-S): anything in the project, including incoherent data and additionnal data, will be saved. When loaded, tabs will either be valid (green) or invalid (red)."
199            pack $wif.saveall.label -side top -pady 5
200            ttk::label $wif.saveall.l1 -image icon_ok
201            pack $wif.saveall.l1 -side left -pady 5
202            ttk::label $wif.saveall.l2 -image icon_question
203            pack $wif.saveall.l2 -side left -pady 5
204            ttk::label $wif.saveall.l3 -image icon_error -compound left -text "+ (...)" 
205            pack $wif.saveall.l3 -side left -pady 5
206         
207         
208         
209       
210           
211       
212        focus $wif.savegreen.butt
213    }
214   
215   
216    return
217
218   
219}
220
221# Calls for saving and loading files
222
223proc Save_XML_File {mode {typesave "all"} } {
224    global DStree loadApplication metaTree loadedProject workingDir widgetInfo
225   
226   
227    set initialDir $workingDir
228    if {$loadedProject != "none"} {
229        set initialDir [file dirname $loadedProject]
230    } else {
231        set mode "new"
232    }
233   
234   
235    switch $mode {
236       
237       
238        "new" {
239            set msgOpen "New : Choose location to save project"
240           
241            set browsemode [getConfig "config gui paths"]
242            switch $browsemode {
243                "constant" {
244                    set constdir [getConfig "config gui paths constant workingDir"]
245                    set where [tk_getSaveFile -parent .  -initialdir $constdir -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
246                }
247                "auto" {
248                    set initialdircommand " -initialdir $workingDir"
249                    set where [tk_getSaveFile -parent .  -initialdir $workingDir -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
250                }
251                "last" -
252                default {
253                    set where [tk_getSaveFile -parent .  -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
254                }
255            }
256           
257            if {$where == "" } {
258                return
259            }
260            set where "[file rootname $where].xml"
261        }
262        "save_as" {
263            set msgOpen "Save as : Choose location to save project"
264            set where [tk_getSaveFile -parent . -initialdir [file dirname $loadedProject] -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
265            if {$where == "" } {
266                return
267            }
268            set where "[file rootname $where].xml"
269           
270           
271            # copy directory
272            set folderName [file rootname $where]
273            set originFolderName [file rootname $loadedProject]
274            catch {
275                file copy $originFolderName $folderName
276                log "Try to copy $originFolderName into $folderName"
277            } err
278            if {$err != ""} {warning "$err"}
279           
280        }
281        "save" {
282             set where "self"
283        }
284       
285    }
286   
287    saveProject $where "xml" $typesave
288   
289}
290
291
292
293# This proc is a brutal kill and load instruction
294# This avoid the reminiscence of old data in the newly loaded project.
295proc loadProject_as_new { } {
296    global relaunchCmd  configPath loadApplication
297   
298    set msgOpen "Choose the project to load as a new window"
299    set browsemode [getConfig "config gui paths"]
300    switch $browsemode {
301        "constant" {
302            set constdir [getConfig "config gui paths constant workingDir"]
303            set fileName [tk_getOpenFile -parent . -initialdir $constdir -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
304        }
305        "auto" {
306            set initialdircommand " -initialdir $workingDir"
307            set fileName [tk_getOpenFile -parent . -initialdir $workingDir -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
308        }
309        "last" -
310        default {
311            set fileName [tk_getOpenFile -parent .  -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
312     }
313    }
314
315    if {[file exists $fileName]} {
316       
317        set cmd "$relaunchCmd -code $loadApplication -file $fileName &"
318        puts "Executing $cmd"
319        if { [catch [subst { exec $cmd}] fout] } {
320            popup_error "Could not launch application $loadApplication with file $fileName : \n $fout "
321        } else {
322           exit
323        }
324    }
325}
326
327
328
329# This is a redirection to the main load procedure,
330# without killing the present data
331
332proc Load_XML_File {  } {
333    global workingDir
334    set msgOpen "Choose the project to add as a part"
335   
336    set browsemode [getConfig "config gui paths"]
337    switch $browsemode {
338        "constant" {
339            set constdir [getConfig "config gui paths constant workingDir"]
340            set fileName [tk_getOpenFile -parent . -initialdir $constdir -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
341        }
342        "auto" {
343            set initialdircommand " -initialdir $workingDir"
344            set fileName [tk_getOpenFile -parent . -initialdir $workingDir -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
345        }
346        "last" -
347        default {
348            set fileName [tk_getOpenFile -parent .  -title $msgOpen -filetypes [list {{XML file} {.xml}}]]
349     }
350    }
351
352    if {[file exists $fileName]} {
353        loadProject_as_part $fileName                               
354    }
355}
356
357
358
359proc Load_CSV_File { } {
360    global workingDir
361    set msgOpen "Choose the project to load"
362    set fileName [tk_getOpenFile -parent . -title $msgOpen -filetypes [list {{CSV file} {.csv}}]]
363    if {[file exists $fileName]} {
364        loadProject $fileName                               
365    }
366}
367
368proc Save_CSV_File { } {
369    global DStree loadApplication workingDir
370    set msgOpen "Choose location to save project"
371    set fileName [tk_getSaveFile -parent .  -title $msgOpen -filetypes [list {{CSV file} {.CSV}}]]
372    if {$fileName != "" } {
373        set fileNamelpf "[file rootname $fileName].csv"
374        saveProject $fileNamelpf  "csv" "greenonly"     
375    }
376}
377
378
379
380# Preference window
381proc Window_preferences {} {
382 set win .preferences
383   
384    if {[winfo exists $win]} {
385        wm deiconify $win
386        raise $win
387    } else {
388        toplevel $win
389        wm title $win "Preferences"
390        wm attributes $win 
391        ttk::labelframe $win.f -text "Display"
392        pack $win.f -expand 1
393       
394       
395        set theme_list [ttk::style theme names]
396        set theme [lindex $theme_list 0]
397       
398       
399        # theme
400        ttk::label $win.f.theme_lbl -text "Theme test" 
401        ttk::combobox $win.f.theme_cbbox -values  [ttk::style theme names]
402        $win.f.theme_cbbox set $theme 
403        bind $win.f.theme_cbbox <<ComboboxSelected>> [ subst {
404            set theme \[ $win.f.theme_cbbox get\]
405            ThemeUpdate \$theme
406        }]
407        grid $win.f.theme_lbl -column 0 -row 0 -padx 10 -pady 10
408        grid $win.f.theme_cbbox -column 1 -row 0  -padx 10 -pady 10
409         
410    }
411}
412
413
414# Preference window
415proc Window_help_generator {} {
416    global workingDir loadApplication help_name help_rootdir help_level
417    set win .help_generator
418   
419    if {[winfo exists $win]} {
420        wm deiconify $win
421        raise $win
422    } else {
423        toplevel $win
424        wm title $win "Help generation"
425        wm attributes $win 
426       
427        ttk::labelframe $win.f -text "Location"
428        pack $win.f -expand 1  -fill x
429       
430        set help_rootdir "."
431       
432        ttk::label $win.f.dir_lbl -text "Directory" 
433        ttk::entry $win.f.dir_ent -textvariable help_rootdir
434        ttk::button $win.f.dir_but -image  icon_folder -command {
435            set help_rootdir [ tk_chooseDirectory -title "Choose directory to store html help document" -initialdir $workingDir]
436        }
437       
438        set help_name $loadApplication
439       
440        ttk::label $win.f.bname_lbl -text "Basename" 
441        ttk::entry $win.f.bname_ent -textvariable help_name
442       
443        grid $win.f.dir_lbl -column 0 -row 0 -pady 5
444        grid $win.f.dir_ent -column 1 -row 0 -pady 5
445        grid $win.f.dir_but -column 2 -row 0 -pady 5
446       
447        grid $win.f.bname_lbl -column 0 -row 1 -pady 5
448        grid $win.f.bname_ent -column 1 -row 1 -pady 5
449       
450        ttk::labelframe $win.g -text "Generation parameters"
451        pack $win.g -expand 1 -fill x
452       
453        set help_level 1
454       
455        ttk::label $win.g.lvl_lbl -text "Level of detail:" 
456        ttk::radiobutton $win.g.lvl0 -text "0 - Structure only" -value 0 -variable help_level
457        ttk::radiobutton $win.g.lvl1 -text "1 - Descriptions and help" -value 1 -variable help_level
458        ttk::radiobutton $win.g.lvl2 -text "2 - All parameters " -value 2 -variable help_level
459        ttk::radiobutton $win.g.lvl3 -text "3 - XML names, existifs, requires" -value 3 -variable help_level
460   
461        grid $win.g.lvl_lbl -column 0 -row 0 -sticky w
462        grid $win.g.lvl0 -column 1 -row 0 -sticky w -pady {5 0}
463        grid $win.g.lvl1 -column 1 -row 1 -sticky w
464        grid $win.g.lvl2 -column 1 -row 2 -sticky w
465        grid $win.g.lvl3 -column 1 -row 3 -sticky w
466       
467        ttk::button $win.g.gh_butt -text "Generate help" -command {
468            generate_help_html
469        }
470       
471        grid $win.g.gh_butt -column 0 -columnspan 2 -row 4 -pady 10 
472       
473        ttk::frame $win.h
474        pack $win.h -expand 1 -fill x
475       
476        ttk::label $win.h.desc  -foreground [ThemeColor 0.20] -text "This dialog allows to generate an HTML file by\ncompiling all the help and descriptions present \nin the GUI. Any web browser can read this file."
477        pack $win.h.desc -expand 1 -fill x -padx 10 -pady 20
478       
479    }
480}
481
482
483proc Window_about {} {
484global engine_version
485 set win .about
486   
487    if {[winfo exists $win]} {
488        wm deiconify $win
489        raise $win
490    } else {
491        toplevel $win
492        wm title $win "About engine "
493        wm attributes $win
494       
495        ttk::frame $win.frame
496        pack $win.frame
497       
498        set wif $win.frame
499       
500        ttk::label $wif.icon -image icon_gui_small
501        pack $wif.icon -side top
502        ttk::labelframe $wif.v -text "Engine Version"
503       
504        ttk::label $wif.v.lbl -justify center -text "$engine_version "       
505        pack $wif.v.lbl -expand 1       
506       
507        pack $wif.v -expand 1 -side top -padx 10 -pady 10
508        #pack $wif.c -expand 1 -side top -padx 10 -pady 10
509        pack $wif.d -expand 1 -side top -padx 10 -pady 10
510       
511         
512        ttk::label $wif.cerfacs -image icon_cerfacs -compound left -text "OpenTEA engine is an open-source product of Cerfacs \n under Cecill-B license."
513        pack $wif.cerfacs -side top -pady 10
514    }
515}
516
517
518# create a splash screen to show documentation (and maybe other stuff)
519proc CreateSplashScreen {  } {
520    set win .splash
521    if {[winfo exists $win]} {
522     destroy $win
523    }
524    toplevel $win -background [ThemeColor 0.3]
525    wm title $win ""
526    #wm attributes $win -alpha 0.95
527    wm geometry $win 600x500
528    label $win.exit -text  "EXIT" -foreground [ThemeColor 0.9] -background [ThemeColor 0.3]
529    place $win.exit -relx 0.5 -rely 0.90
530    bind $win.exit <ButtonPress> [subst {destroy $win}]
531
532    return $win
533}
534
535
536# Memory browsers
537
538proc Window_DStree { win} {
539    global DStree
540    #set win .treeviewDS
541   
542    if {[winfo exists $win]} {
543        wm deiconify $win
544        raise $win
545    } else {
546        toplevel $win
547        wm title $win "Check DS tree content"
548        wm attributes $win 
549        ttk::labelframe $win.f -text "Tree view"
550        dTreeBrowser_create $win.f.tree
551        dTreeBrowser_fill $win.f.tree $DStree
552        pack $win.f.tree -expand 1 -fill both
553       
554       
555        pack $win.f -side top -expand 1 -fill both
556        pack $win.f.tree
557           
558        ttk::labelframe $win.bottom
559        ttk::separator $win.bottom.s
560        ttk::button $win.bottom.b -text "Refresh" -command [subst {
561            destroy $win.f.tree
562            dTreeBrowser_create $win.f.tree
563            pack $win.f.tree -expand 1 -fill both
564            dTreeBrowser_fill $win.f.tree \$DStree
565        }]
566
567        pack $win.bottom -side top -fill x
568        pack $win.bottom.s -side top -fill x
569        pack $win.bottom.b -side right -padx 5 -pady 5
570    }
571}
572
573proc Window_tmptree { win} {
574    global tmpTree
575    #set win .treeviewDS
576   
577    if {[winfo exists $win]} {
578        wm deiconify $win
579        raise $win
580    } else {
581        toplevel $win
582        wm title $win "Check tmp tree content"
583        wm attributes $win 
584        ttk::labelframe $win.f -text "Tree view"
585        dTreeBrowser_create $win.f.tree
586        dTreeBrowser_fill $win.f.tree $tmpTree 1
587        pack $win.f.tree -expand 1 -fill both
588       
589       
590        pack $win.f -side top -expand 1 -fill both
591        pack $win.f.tree
592           
593        ttk::labelframe $win.bottom
594        ttk::separator $win.bottom.s
595        ttk::button $win.bottom.b -text "Refresh" -command [subst {
596            destroy $win.f.tree
597            dTreeBrowser_create $win.f.tree
598            pack $win.f.tree -expand 1 -fill both
599            dTreeBrowser_fill $win.f.tree \$tmpTree 1
600        }]
601
602        pack $win.bottom -side top -fill x
603        pack $win.bottom.s -side top -fill x
604        pack $win.bottom.b -side right -padx 5 -pady 5
605    }
606}
607
608proc Window_XMLtree {win} {
609    global XMLtree
610    #set win .treeviewXML
611   
612    if {[winfo exists $win]} {
613        wm deiconify $win
614        raise $win
615    } else {
616        toplevel $win
617        wm title $win "Check XML tree content"
618        wm attributes $win 
619        ttk::labelframe $win.f -text "Tree view"
620        dTreeBrowser_create $win.f.tree
621        dTreeBrowser_fill $win.f.tree $XMLtree
622        pack $win.f.tree -expand 1 -fill both
623        pack $win.f -side top -expand 1 -fill both
624        pack $win.f.tree
625           
626    }
627}
628
629# Console for debug
630# Allow to execute short bit of code within the execution of the GUI
631proc Window_console {} {
632    set win .devConsole
633    if {[winfo exists $win]} {
634        wm deiconify $win
635        raise $win
636    } else {
637        toplevel $win
638        wm title $win "Execute some TclTk script on-the-fly"
639        wm attributes $win 
640        ttk::labelframe $win.f -text "Script to execute \n (use right click to insert widget)"
641        text $win.f.input -relief sunken -background [ThemeColor 1.1]
642        pack $win.f -side top -expand 1 -fill both
643        pack $win.f.input -expand 1 -fill both
644           
645        ttk::labelframe $win.bottom
646        ttk::separator $win.bottom.s
647        ttk::button $win.bottom.b -text "Execute" -command {
648            eval [.devConsole.f.input get 1.0 end]
649        }
650        pack $win.bottom -side top -fill x
651        pack $win.bottom.s -side top -fill x
652        pack $win.bottom.b -side right -padx 5 -pady 5
653       
654        bind . <ButtonPress-2> { .devConsole.f.input insert end %W }
655    }
656}
657
658
659# Creation de la fenetre de suivi de la memoire.
660# Juge en particulier la taille en nombre de caracteres des donnees sotckees.
661proc Window_memory { } {
662    set win .devMemory
663    if {[winfo exists $win]} {
664        wm deiconify $win
665        raise $win
666    } else {
667        toplevel $win
668        wm title $win "Show current memory allocation"
669        wm attributes $win 
670        ttk::labelframe $win.f -text "Memory allocation"
671        set width 640
672        set height 480
673       
674       
675        pack $win.f -side top -expand 1 -fill both
676       
677        canvas $win.f.can -width $width -height $height
678        pack $win.f.can -expand 1 -fill both -side top -padx 5 
679       
680        text $win.f.txt -width 50 -height 10
681        pack $win.f.txt -expand 1 -fill both -side top -padx 5
682       
683        Window_memory_trace $win $width $height
684       
685        button $win.f.butt -text "Update" -command [subst {Window_memory_trace $win $width $height}]
686        pack $win.f.butt -expand 1 -side top -fill both -padx 5 -pady 5
687       
688    }
689   
690}
691
692# Plot de l'occupation memoire
693proc Window_memory_trace { win width height} {
694   
695    $win.f.can delete all
696    set mem_info [ Window_memory_get ]
697    set mem_size [lindex $mem_info 0 ]
698    set mem_list [lrange $mem_info 1 end ]
699   
700   
701    # memory repartition
702    set x0 [expr {int(0.1*$width)}]
703    set y0 [expr {int(0.2*$height)}]
704    set h [expr {int(0.2*$height)}]
705    set span [expr {int(0.8*$width)}]
706   
707   
708    canvas_text_vector $win.f.can $x0 [expr {$y0-20}] "Memory distribution" "e" 10 0 black ""
709   
710   
711    canvas_text_vector $win.f.can $x0 $y0 "0%" "se" 10 45 black ""
712    foreach item $mem_list {
713        set name [lindex $item 0]
714        set size [expr {int($span*[lindex $item 1])}]
715        set ratio [format %0.0f [expr {[lindex $item 1]*100. }]]
716        $win.f.can create rectangle $x0 $y0 [expr {$x0 +$size}] [expr {$y0 +$h}] -fill [randcolor] -tags "$name"
717        incr x0 $size
718        $win.f.can bind "$name" <Motion> [subst {
719            $win.f.can delete "hl"
720            canvas_text_highlighted $win.f.can %x %y  "$name ($ratio/100)" "hl"
721        }]
722    }
723    canvas_text_vector $win.f.can $x0 $y0 "100%" "se" 10 45 black ""
724   
725    set x0 [expr {int(0.1*$width)}]
726    set y0 [expr {int(0.6*$height)}]
727   
728    set bins 10
729    set minbins 5
730   
731    set binspan [expr {int($span/$bins)}]
732    set x1 [expr {int($x0 + $span * log10($mem_size)/$bins)}]
733   
734   
735   
736    canvas_text_vector $win.f.can $x0 $y0 "Memory total  [commify $mem_size] symbols"  "e" 10 0 black ""
737    set y0 [expr {int(0.7*$height)}]
738    set h [expr {int(0.05*$height)}]
739   
740   
741    set cl [colorscale_define rainbow]
742    set color [colorscale_get $cl [expr { (log10($mem_size) - $minbins)/($bins - $minbins) }]]
743    for {set bin 0} {$bin <= $bins } {incr bin} {
744        canvas_text_vector $win.f.can [expr {$x0+$bin*$binspan}] $y0 "[format %g [expr {10**$bin}]]"  "se" 10 45 black ""
745    }
746    $win.f.can create rectangle $x0 $y0 $x1 [expr {$y0 +$h}] -fill $color
747   
748    $win.f.txt insert end "\n [commify $mem_size] symbols"
749   
750}
751
752# Recuperation de l'occupation memoire
753proc Window_memory_get { } {
754    uplevel #0 {
755
756        set list_memory ""
757        set total_char 0
758        foreach var [info vars ] {
759            if {[array exists $var]} {
760                set names [array names $var]
761               
762               
763                set ll 0   
764                foreach name $names {
765                    incr ll [string length [subst $[subst $var]($name)] ]
766                }
767                incr total_char $ll
768               
769                set tll 0
770                foreach cat "status check refresh refreshstatus existIf require" {
771                    set tl 0
772                    foreach name $names {
773                        if {[string match "*$cat" $name  ]} {
774                            incr tl [string length [subst $[subst $var]($name)] ]
775                        }
776                       
777                    }
778                    lappend list_memory "$var.$cat $tl" 
779                    incr tll $tl   
780                }
781               
782                lappend list_memory "$var.misc [expr {$ll-$tll}]" 
783                   
784               
785               
786               
787               
788            } else {
789                set ll [string length [subst $$var]]
790                lappend list_memory "$var $ll" 
791                incr total_char $ll
792            }
793           
794        }
795
796        set list_memory [lsort -index 1 -integer $list_memory]
797        set result "$total_char"
798        foreach rec $list_memory {
799            set size [format "%0.4f" [expr {[lindex $rec 1]*1./$total_char}]]
800           
801            if {$size > 0} {
802                lappend result "[lindex $rec 0] [format "%0.4f" [expr {[lindex $rec 1]*1./$total_char}]]"
803            }
804        }   
805    return $result   
806    }
807   
808}
809
810# Creation de la fenetre de profiling des fonction.
811# N'est accessible qu'en mode debug (wrapper.tcl a la place de" unwrap.tcl.
812# la taile memoire utilisee explose, car on enregistre les debuts et fins de chaque fonction.
813proc Window_profiling { } {
814    set win .devProfiling
815    if {[winfo exists $win]} {
816        wm deiconify $win
817        raise $win
818    } else {
819        toplevel $win
820        wm title $win "Show  profiling "
821        wm attributes $win 
822        ttk::labelframe $win.f -text "Profiling"
823        set width 640
824        set height 480
825       
826        pack $win.f -side top -expand 1 -fill both
827        canvas $win.f.can -width $width -height $height
828        pack $win.f.can -expand 1 -fill both -side top -padx 5 
829       
830        text $win.f.txt -width 50 -height 10
831        pack $win.f.txt -expand 1 -fill both -side top -padx 5
832       
833        Window_profiling_trace $win $width $height
834       
835        button $win.f.butt -text "Clean" -command [subst {Window_profiling_clean $win}]
836        pack $win.f.butt -expand 1 -side top -fill both -padx 5 -pady 5
837        button $win.f.butt2 -text "Current profile" -command [subst {Window_profiling_trace $win $width $height}]
838        pack $win.f.butt2 -expand 1 -side top -fill both -padx 5 -pady 5
839       
840       
841    }
842   
843}
844
845# plot e l'occupation memoire
846proc Window_profiling_trace { win width height} {
847    global TraceProfile
848   
849   
850    set TraceProfile 0
851   
852    $win.f.can delete all
853    set prof_info [ Window_profiling_get ]
854    set prof_ttime [lindex $prof_info 0 ]
855    set prof_ttocc [lindex $prof_info 1 ]
856    set prof_list [lrange $prof_info 2 end ]
857   
858   
859   
860   
861    ## profiling repartition
862    set x0 [expr {int(0.3*$width)}]
863    set y0 [expr {int(0.2*$height)}]
864    set h 10
865    set span [expr {int(0.7*$width)}]
866    #
867    #
868    #canvas_text_vector $win.f.can $x0 [expr {$y0-20}] "Memory distribution" "e" 10 0 black ""
869    #
870    #
871    #canvas_text_vector $win.f.can $x0 $y0 "0%" "se" 10 45 black ""
872    foreach item $prof_list {
873        set name [lindex $item 0]
874        set sizet [expr {int($span*[lindex $item 1]*1./$prof_ttime)}]
875        set sizeo [expr {int($span*[lindex $item 2]*1./$prof_ttocc)}]
876       
877       
878        $win.f.can create rectangle $x0 $y0 [expr {$x0 +$sizet}] [expr {$y0 +$h}] -fill red -tags "$name"
879        $win.f.can create rectangle $x0 [expr {$y0 +$h}] [expr {$x0 +$sizeo}] [expr {$y0 +2*$h}] -fill orange -tags "$name"
880       
881        canvas_text_vector $win.f.can $x0 $y0 "$name" "nw" 10 0 black ""
882       
883        incr y0 30
884       
885        $win.f.can bind "$name" <Motion> [subst {
886            $win.f.can delete "hl"
887            canvas_text_highlighted $win.f.can %x %y  "$name \ntime=[commify [lindex $item 1]] microsecondes \noccurences=[lindex $item 2] \n [lindex $item 2]/$prof_ttocc " "hl"
888        }]
889    }
890   
891    set TraceProfile 1
892}
893
894# nettoyage de la fenetre de profiling des fonctions
895proc Window_profiling_clean {win } {
896    global FunctionUsed
897    global FunctionTime
898    foreach name [array names FunctionUsed ] {
899        set FunctionUsed($name) 0
900    }
901    set FunctionTime ""
902    $win.f.can delete all
903    return
904}
905
906
907# analyse de la donnee de profiling
908proc Window_profiling_get { } {
909   
910    global FunctionUsed, FunctionTime, TraceProfile
911    set list_profiling ""
912    set total_char 0
913    set tot_occur 0
914    puts "Wrapper says : "
915   
916    #INITS
917    set FuncNames [array names FunctionUsed ]
918    foreach fun $FuncNames {
919        set FuncCost($fun) 0
920        set FuncOccur($fun) 0
921    }
922
923    # DATA MINING
924    set tim0 [lindex [split [lindex $FunctionTime 0] "#"] 2 ]
925    set fun0 [lindex [split [lindex $FunctionTime 0] "#"] 1 ]
926   
927    set t0 $tim0
928   
929    foreach item [lrange $FunctionTime 1 end] {
930        set state [lindex  [split $item "#"] 0]
931        set fun [lindex  [split $item "#"] 1]
932        set tim [lindex  [split $item "#"] 2]
933       
934        set dtim [expr {$tim-$tim0}]
935        switch $state {
936            "IN" {
937                #puts "$fun0 $dtim"
938                incr FuncCost($fun0) $dtim
939                incr FuncOccur($fun)
940                incr tot_occur
941               
942            }
943            "OUT" {
944                #puts "$fun $dtim"
945                incr FuncCost($fun) $dtim
946            }
947        }
948        set fun0 $fun
949        set tim0 $tim
950       
951    }
952   
953   
954    # SORTING
955    set list_time ""
956    set list_occur ""
957    set tot_time 0
958   
959   
960    foreach func $FuncNames {
961        set dtim [format "%0.6f" [expr { $FuncCost($func)*0.000001 }]]
962        if { $dtim > 0 } {
963            lappend list_time "$func $FuncCost($func) $FuncOccur($func)"
964            incr tot_time  $FuncCost($func)
965        }
966       
967    }
968   
969   
970   
971    set list_time "$tot_time $tot_occur [lsort -index 1 -decreasing -real $list_time]"
972   
973   
974   
975    #puts "Total time  [format "%0.3f" [expr { $tot_time*0.000001 }]] s."
976    #puts "Total time  [format "%0.3f" [expr { ($tim0-$t0)*0.000001 }]] s."
977    return $list_time
978   
979}
980
981
982# Console pemettant d'identifier l'historique du packing
983
984proc Window_packing {} {
985    set win .devPacking
986    if {[winfo exists $win]} {
987        wm deiconify $win
988        raise $win
989    } else {
990        toplevel $win
991        wm title $win "Show the packing history of a widget"
992        wm attributes $win 
993        ttk::labelframe $win.f -text "Packing \n (use right click to insert widget)"
994        text $win.f.input -relief sunken -background [ThemeColor 1.1]
995        $win.f.input insert end "right click in the main window to get the packing history"
996        $win.f.input configure -state disabled
997        pack $win.f -side top -expand 1 -fill both
998        pack $win.f.input -expand 1 -fill both
999       
1000        bind . <ButtonPress-2> [subst { Window_show_packing $win %W }]
1001    }
1002}
1003
1004# action de recherche du packing
1005proc Window_show_packing { win widget} {
1006    global widgetInfo
1007        set win_list [split $widget "."]
1008       
1009        $win.f.input configure -state normal   
1010        $win.f.input delete 1.0 end
1011       
1012        set depth [llength $win_list]
1013        incr depth -1
1014        for {set lvl $depth} {$lvl>=1} {incr lvl -1} {
1015            set address "[join [lrange $win_list 0 $lvl] "." ]"
1016            $win.f.input insert end "\n" 
1017            $win.f.input insert end "[winfo class $address] $address \n"           
1018            $win.f.input insert end " manager:[winfo manager $address]\n"
1019            $win.f.input insert end " children:\n[join [winfo children $address] "\n"] \n\n"
1020           
1021            $win.f.input insert end "Absolute widthXheight     :[winfo width $address]X[winfo height $address]\n"
1022            $win.f.input insert end "Required widthXheight     :[winfo reqwidth $address]X[winfo reqheight $address]\n"
1023            $win.f.input insert end "Geometry  widthxheight+x+y:[winfo geometry $address]\n"
1024            $win.f.input insert end "Small Widgets  :$widgetInfo(guiSmallWidgetWidth) pixels\n"
1025            $win.f.input insert end "Big Widgets  :$widgetInfo(guiBigWidgetWidth) pixels\n"
1026           
1027        }
1028        $win.f.input configure -state disabled
1029}
1030
1031
1032#  update of title
1033proc updateTitle {} {
1034    global loadApplication
1035    global loadedProject
1036   
1037    wm title . "OpenTEA  [string toupper $loadApplication]  -  [file tail [file rootname $loadedProject]]"
1038}
1039
1040
1041
1042proc Window_faq {faqname} {
1043    global faqdata
1044    set win [CreateSplashScreen]
1045    text $win.text  -foreground [ThemeColor 0.]  -background [ThemeColor 1.1] -highlightthickness 0 -yscrollcommand [list $win.sbary set]
1046    ttk::scrollbar $win.sbary -orient vertical -command [list $win.text yview]
1047   
1048     
1049    $win.text insert end "\n$faqdata($faqname-title) \n" "Title"
1050   
1051    $win.text configure -wrap word
1052    $win.text tag configure "Body" -font "helvetica 12 " -lmargin1 40 -lmargin2 30 -rmargin 30 -foreground [ThemeColor 0.50]
1053    $win.text tag configure "Title" -font "helvetica 16 bold" -justify center -foreground [ThemeColor 0.80]
1054    $win.text tag configure "Section" -font "helvetica 12 bold"  -lmargin1 40 -lmargin2 30 -rmargin 30  -foreground [ThemeColor 0.65]
1055    $win.text tag configure "Float" -font "helvetica 12 bold" -justify center -foreground [ThemeColor 0.50]
1056    $win.text tag configure "Item" -font "helvetica 12 " -lmargin1 70 -lmargin2 30 -rmargin 30 -foreground [ThemeColor 0.50]
1057   
1058   
1059       
1060    #$win.text insert end "\nFreezing application \n" "Section"
1061
1062    $win.text insert end "\n $faqdata($faqname-body) \n" "Body"
1063 
1064   
1065   
1066    place  $win.text -relx 0.1 -rely 0.1 -relwidth 0.8 -relheight 0.8
1067    place  $win.sbary -relx 0.9 -rely 0.1  -relheight 0.8 -anchor ne
1068    $win.text configure -state disabled
1069   
1070}
1071
1072
1073# experiment.
1074
1075proc temp_launch_py {} {
1076    global widgetInfo XDRpath
1077    puts "plouf!"
1078   
1079    set win "plop"
1080    set address "bliblablo"
1081   
1082    set widgetInfo($address-cancellation) 0
1083   
1084    set widgetInfo($address-onScriptStarts) ""
1085   
1086    set widgetInfo($address-onScriptStops) ""
1087   
1088    set widgetInfo($address-updateProgress) ""
1089   
1090    set widgetInfo($address-onScriptEnds) ""
1091   
1092    set widgetInfo($address-scriptAddress) [file normalize [file join $XDRpath "hello.py"]]
1093   
1094   
1095    openPipe $win $address 
1096}
1097
1098
1099
1100#  Copyright CERFACS 2014
1101#   
1102#  antoine.dauptain@cerfacs.fr
1103#   
1104#  This software is a computer program whose purpose is to ensure technology
1105#  transfer between academia and industry.
1106#   
1107#  This software is governed by the CeCILL-B license under French law and
1108#  abiding by the rules of distribution of free software.  You can  use,
1109#  modify and/ or redistribute the software under the terms of the CeCILL-B
1110#  license as circulated by CEA, CNRS and INRIA at the following URL
1111#  "http://www.cecill.info".
1112#   
1113#  As a counterpart to the access to the source code and  rights to copy,
1114#  modify and redistribute granted by the license, users are provided only
1115#  with a limited warranty  and the software's author,  the holder of the
1116#  economic rights,  and the successive licensors  have only  limited
1117#  liability.
1118#   
1119#  In this respect, the user's attention is drawn to the risks associated
1120#  with loading,  using,  modifying and/or developing or reproducing the
1121#  software by the user in light of its specific status of free software,
1122#  that may mean  that it is complicated to manipulate,  and  that  also
1123#  therefore means  that it is reserved for developers  and  experienced
1124#  professionals having in-depth computer knowledge. Users are therefore
1125#  encouraged to load and test the software's suitability as regards their
1126#  requirements in conditions enabling the security of their systems and/or
1127#  data to be ensured and,  more generally, to use and operate it in the
1128#  same conditions as regards security.
1129#   
1130#  The fact that you are presently reading this means that you have had
1131#  knowledge of the CeCILL-B license and that you accept its terms.
Note: See TracBrowser for help on using the repository browser.