44c017072c0735edbb6a7ef05c944c97c4df917b
[occt.git] / src / DrawResources / DrawTK.tcl
1 # Copyright (c) 1999-2014 OPEN CASCADE SAS
2 #
3 # This file is part of Open CASCADE Technology software library.
4 #
5 # This library is free software; you can redistribute it and/or modify it under
6 # the terms of the GNU Lesser General Public License version 2.1 as published
7 # by the Free Software Foundation, with special exception defined in the file
8 # OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
9 # distribution for complete text of the license and disclaimer of any warranty.
10 #
11 # Alternatively, this file may be used under the terms of Open CASCADE
12 # commercial license or contractual agreement.
13
14 #
15 # TK features for Draw
16 #
17
18 # reload bindings
19 if { [info exists tk_library] } {
20     set version [split [info tclversion] "."]
21     set major [lindex ${version} 0]
22     set minor [lindex ${version} 1]
23     if { (${major} > 8) || (${major} >= 8 && ${minor} >= 4) } {
24         #source $tk_library/tk.tcl
25     } else {
26         source $tk_library/tk.tcl
27     }
28 }
29
30 #fills menu "Load" with submenus
31 proc fillloadmenu {} {
32   set chan [open [file nativename $::env(CASROOT)/src/DrawResources/DrawPlugin]]
33   while {[gets $chan line] >= 0} {
34     if {[lindex [split $line ""] 0] != "!"} {
35       if {[lindex [split $line ""] 0] == ""} {continue}
36         set plugname [lindex [split $line " "] 0]
37         addmenu Load "pload $plugname" "pload $plugname"
38     }
39   }
40   close $chan
41 }
42
43 wm geometry . +10+10
44 bind . <F1> {vcommands}
45
46 frame .mbar -relief raised -bd 2
47 pack .mbar -side top -fill x
48 focus .mbar
49
50 set theMenus("") ""
51 set Draw_MenuIndex 0
52
53 proc addmenuitem {menu options} {
54
55     global theMenus Draw_MenuIndex
56     if {![info exists theMenus($menu)]} {
57         incr Draw_MenuIndex
58         set m .mbar.m$Draw_MenuIndex.menu
59         menubutton .mbar.m$Draw_MenuIndex -text $menu -menu $m
60         pack .mbar.m$Draw_MenuIndex -side left
61         menu $m
62         set theMenus($menu) $m
63     } else {set m $theMenus($menu)}
64
65     eval $m add $options
66 }
67
68 proc addmenu {menu submenu {command ""}} {
69     if {$command == ""} {set command $submenu}
70     addmenuitem $menu "command -label {$submenu} -command {$command}"
71 }
72
73 #################################
74 # Menus definition
75 #################################
76
77 # the file menu
78
79 addmenu File "Choose Data Directory" vdatadir
80 addmenu File "Load Shape (restore)" vrestore
81 addmenu File "Load Script (source)" vsource
82 addmenu File Exit exit
83
84 # the Load menu
85 fillloadmenu
86
87 # the view menu
88
89 addmenu Views axo   {smallview AXON}
90 addmenu Views top   {smallview +X+Y}
91 addmenu Views front {smallview +X+Z}
92 addmenu Views left  {smallview +Y+Z}
93 addmenu Views 2d    {smallview -2D-}
94 addmenuitem Views   "separator"
95 addmenu Views mu4
96 addmenu Views av2d
97 addmenu Views axo
98 addmenu Views pers
99
100 # the display menu
101
102 addmenu Display fit   "fit; repaint"
103 addmenu Display 2dfit "2dfit; repaint"
104 addmenu Display clear
105 addmenu Display 2dclear
106
107 # the samples menu
108 addmenu Samples "View samples" vsample
109
110 # the help menu
111
112 addmenu Help "System Info" sysinfo
113 addmenu Help Commands vcommands
114 addmenu Help About about
115 addmenu Help "User Guide" openuserguide
116
117 #redraw help submenu in the end of menu
118 proc redrawhelp {} {
119   global theMenus
120   set m $theMenus(Help)
121   destroy [string trimright $m ".menu"]
122   if [info exists theMenus(Help)] {unset theMenus(Help)}
123   addmenu Help "System Info" sysinfo
124   addmenu Help Commands vcommands
125   addmenu Help About about
126   addmenu Help "User Guide" openuserguide
127 }
128
129 #################################
130 # Modal dialog box
131 # add OK, help, cancel buttons
132 #################################
133
134 proc modaldialog {box okproc {helpproc ""} {cancelproc ""}} {
135     wm geometry $box +10+60
136     button $box.ok -text ok -command "$okproc ; destroy $box"
137     pack $box.ok -side left
138     button $box.ko -text Cancel -command "$cancelproc ; destroy $box"
139     pack $box.ko -side right
140     if {$helpproc != ""} {
141         button $box.help -text Help -command $helpproc
142         pack $box.help -side right
143     }
144     grab set $box
145 }
146
147
148 #################################
149 # File menu procedures
150 #################################
151
152 ##############################
153 #
154 # dialbox command arg1 val1 arg2 val2 ...
155 #
156 ##############################
157
158 proc dialbox args {
159     set com [lindex $args 0]
160
161     toplevel .d
162     wm title .d $com
163
164     # com will be the command
165     set com "eval $com"
166
167     # create entries for the arguments
168     set n [llength $args]
169
170     for {set i 1} {$i < $n} {incr i 2} {
171
172         frame .d.a$i
173         label .d.a$i.l -text [lindex $args $i]
174         entry .d.a$i.e -relief sunken
175         .d.a$i.e insert end [lindex $args [expr $i+1]]
176         pack .d.a$i.l -side left
177         pack .d.a$i.e -side right
178         pack .d.a$i -side top -fill x
179
180         append com { [} ".d.a$i.e get" {]}
181     }
182     append com ";repaint"
183
184     modaldialog .d $com "help [lindex $args 0]"
185         }
186 proc sdatadir {d} {
187   global Draw_DataDir
188   set Draw_DataDir $d
189 }
190
191 proc vdatadir {} {
192   global Draw_DataDir
193   sdatadir [tk_chooseDirectory -title "Data Directory" -initialdir $Draw_DataDir]
194 }
195
196 proc rresto {f} {
197   if {[file exists $f]} {
198     if {! [file isdirectory $f]} {
199       puts "restore $f [file tail $f]"
200       uplevel \#0 "restore $f [file tail $f]"
201       repaint
202     }
203   }
204 }
205
206 proc vrestore {} {
207   global Draw_DataDir
208   rresto [tk_getOpenFile -title "Load Shape (restore)" -filetypes {{{BREP} {.brep}}} -initialdir $Draw_DataDir]
209 }
210
211
212 proc ssour {f} {
213   global Draw_Source
214   if {[file exists $f]} {
215     set Draw_Source $f
216     if {! [file isdirectory $f]} {
217       puts "source $f [file tail $f]"
218       uplevel \#0 "source $f"
219     }
220   }
221 }
222
223 set Draw_Source [pwd]
224 proc vsource {} {
225   global Draw_Source
226   ssour [tk_getOpenFile -title "Load Script (source)" -filetypes {{{All Files} *}} -initialdir Draw_Source]
227 }
228
229 #Creates a "Samples" window
230 proc vsamples {} {
231   #create list {{category} {title} {filename}}
232   set alistofthree ""
233   foreach fname [file nativename  [glob -path $::env(CASROOT)/samples/tcl/ *]] {
234    if {[lindex [split $fname "."] end] != "tcl"} {continue}
235     set chan [open $fname]
236     set istitlefound 0
237     while {[gets $chan line] >= 0} {
238       if {[lindex [split $line " "] 0] == "#Category:"} {
239         set acategory [string trimleft $line "#Category: "]
240       }
241       if {[lindex [split $line " "] 0] == "#Title:"} {
242         set atitle [string trimleft $line "#Title: "]
243         lappend alistofthree $acategory $atitle $fname
244         incr istitlefound
245         break
246       }
247     }
248     close $chan
249     if {$istitlefound == 0} {
250     lappend alistofthree Other "[lindex [split $fname \\] end]" $fname
251     }
252   }
253   #create window
254   toplevel .samples
255   wm title .samples "Samples"
256   wm geometry .samples +0+0
257   wm minsize .samples 800 600
258   frame .samples.right
259   frame .samples.left
260   frame .samples.right.textframe
261   frame .samples.right.botframe
262   ttk::treeview .samples.left.tree -selectmode browse -yscrollcommand {.samples.left.treescroll set}
263   pack .samples.left.tree -fill both -expand 1 -side left
264   .samples.left.tree column #0 -minwidth 200
265   .samples.left.tree heading #0 -text "Samples"
266   pack .samples.right -side right -fill both -expand 1 -padx 10 -pady 10
267   pack .samples.left -side left -padx 10 -pady 10 -fill both
268   pack .samples.right.textframe -side top -fill both -expand 1
269   pack .samples.right.botframe -side bottom -fill both -expand 1
270   text .samples.right.textframe.text -yscrollcommand {.samples.right.textframe.scroll set} -xscrollcommand {.samples.right.botframe.scrollx set} -wrap none -width 40 -height 32
271   pack .samples.right.textframe.text -fill both -side left -expand 1
272   .samples.right.textframe.text delete 0.0 end
273   .samples.right.textframe.text configure -state disabled
274   set i 1
275   foreach {acat title fnam} $alistofthree {
276     if [.samples.left.tree exists $acat] {
277       .samples.left.tree insert $acat end -id $title -text $title -tags "selected$i"
278       .samples.left.tree tag bind selected$i <1> "fillsampletext {$fnam}"
279       incr i
280       continue
281     } else {
282       .samples.left.tree insert {} end -id $acat -text $acat
283       .samples.left.tree insert $acat end -id $title -text $title -tags "selected$i"
284       .samples.left.tree tag bind selected$i <1> "fillsampletext {$fnam}"
285       incr i
286     }
287   }
288   scrollbar .samples.right.textframe.scroll -command {.samples.right.textframe.text yview}
289   scrollbar .samples.left.treescroll -command {.samples.left.tree yview}
290   scrollbar .samples.right.botframe.scrollx -command {.samples.right.textframe.text xview} -orient horizontal
291   pack .samples.right.textframe.scroll -side right -fill y
292   pack .samples.right.botframe.scrollx -side top -fill x
293   pack .samples.left.treescroll -side right -fill y
294   button .samples.right.botframe.button -text "Run sample" -state disabled
295   pack .samples.right.botframe.button -fill none -pady 10
296 }
297
298 #Fills the textbox in "Samples" window
299 proc fillsampletext {fname} {
300   .samples.right.botframe.button configure -state normal -command "lower .samples;catch {vclose ALL};catch {vremove -all}; catch {vclear}; source {$fname}"
301   .samples.right.textframe.text configure -state normal
302   .samples.right.textframe.text delete 0.0 end
303   set chan [open "$fname"]
304     while {[gets $chan line] >= 0} {
305     .samples.right.textframe.text insert end "$line\n"
306     }
307   close $chan
308   .samples.right.textframe.text configure -state disabled
309 }
310
311 #Creates a "Commands help" window
312 proc vcommands {} {
313   global Draw_Groups Find_Button_Click_Count Entry_Cache
314   set Find_Button_Click_Count 0
315   set Entry_Cache ""
316   toplevel .commands
317   focus .commands
318   wm minsize .commands 800 600
319   wm title .commands "Commands help"
320   wm geometry .commands +0+0
321   frame .commands.t
322   frame .commands.left
323   ttk::treeview .commands.left.tree -selectmode browse -yscrollcommand {.commands.left.treescroll set}
324   .commands.left.tree column #0 -width 300
325   .commands.left.tree heading #0 -text "Help treeview"
326   pack .commands.left.tree -expand 1 -fill both -side left
327   pack .commands.t -side right -fill both -expand 1 -padx 10 -pady 10
328   pack .commands.left -side left -fill both -padx 10 -pady 10
329   pack [frame .commands.t.top] -side top -fill x -padx 10 -pady 10
330   text .commands.t.text -yscrollcommand {.commands.t.scroll set} -width 40
331   .commands.t.text delete 0.0 end
332   pack .commands.t.text -fill both -side left -expand 1
333   .commands.t.text configure -state disabled
334   pack [entry .commands.t.top.e  -width 20] -side left
335   pack [button .commands.t.top.findcom -text "Find command" -command vhelpsearch] -side left -padx 10
336   pack [button .commands.t.top.textfind -text "Find in text" -command "vhelptextsearch; incr Find_Button_Click_Count"] -side left
337   set i 1
338   set j 100
339   set newgroupinx 0
340   foreach h [lsort [array names Draw_Groups]] {
341   .commands.left.tree insert {} end -id $i -text $h -tags "info$i"
342   .commands.left.tree tag bind info$i <1> "vcomhelp {$h}"
343   set newgroupinx $j
344     foreach f [lsort $Draw_Groups($h)] {
345       .commands.left.tree insert $i end -id $j -text $f  -tags "selected$j"
346       .commands.left.tree tag bind selected$j <1> "vcomhelp {$h} $j $newgroupinx"
347        incr j
348     }
349    incr i
350   }
351   scrollbar .commands.t.scroll -command {.commands.t.text yview}
352   scrollbar .commands.left.treescroll -command {.commands.left.tree yview}
353   pack .commands.t.scroll -side right -fill y
354   pack .commands.left.treescroll -side right -fill y -expand 1
355   #hotkeys
356   bind .commands.t.top.e <Return> {vhelpsearch}
357   bind .commands <Control-f> {focus .commands.t.top.e}
358   bind .commands <Control-F> {focus .commands.t.top.e}
359   bind .commands <Escape> {destroy .commands}
360   }
361
362 ############################################################
363 # Fills the textbox in "Commands help" window
364 # $h -group of commands to display
365 # $selindex - index of selected item in the treeview
366 # $startindex - index of item int the treeview to start from
367 ############################################################
368 proc vcomhelp {h {selindex -1} {startindex 0}} {
369   global Draw_Helps Draw_Groups
370   set highlighted false
371   .commands.t.text configure -state normal
372   .commands.t.text delete 1.0 end
373   foreach f [lsort $Draw_Groups($h)] {
374     if {$startindex == $selindex} {
375       .commands.t.text insert end "$f : $Draw_Helps($f)\n\n" "highlightline"
376       incr startindex
377       set highlighted true
378       continue
379     }
380     .commands.t.text insert end "$f : $Draw_Helps($f)\n\n"
381     incr startindex
382   }
383   .commands.t.text tag configure highlightline -background yellow -relief raised
384   .commands.t.text configure -state disabled
385   if {$highlighted == true} {.commands.t.text see highlightline.last}
386 }
387
388 #Creates a "About" window
389 proc about {} {
390   toplevel .about
391   focus .about
392   wm resizable .about 0 0
393   wm title .about "About"
394   set screenheight [expr {int([winfo screenheight .]*0.5-200)}]
395   set screenwidth [expr {int([winfo screenwidth .]*0.5-200)}]
396   wm geometry .about 400x200+$screenwidth+$screenheight
397   image create photo occlogo -file $::env(CASROOT)/src/DrawResources/OCC_logo.png -format png
398   frame .about.logo -bg red
399   frame .about.links -bg blue
400   frame .about.copyright
401   pack .about.logo -side top -fill both
402   pack .about.links -fill both
403   pack .about.copyright -side top -fill both
404   label .about.logo.img -image occlogo
405   pack .about.logo.img -fill both
406   text .about.links.text -bg lightgray -fg blue -height 1 -width 10
407   .about.links.text insert end "http://www.opencascade.com/" "link1"
408   .about.links.text tag bind link1 <1> "_launchBrowser http://www.opencascade.com/"
409   .about.links.text tag bind link1 <Enter> ".about.links.text configure -cursor hand2"
410   .about.links.text tag bind link1 <Leave> ".about.links.text configure -cursor arrow"
411   .about.links.text tag configure link1 -underline true -justify center
412   pack .about.links.text -fill both
413   label .about.copyright.text -text "Copyright (c) 1999-2014 OPEN CASCADE SAS"
414   button .about.button -text "OK" -command "destroy .about"
415   pack .about.button -padx 10 -pady 10
416   pack .about.copyright.text
417   .about.links.text configure -state disabled
418   grab .about
419   bind .about <Return> {destroy .about}
420 }
421
422 #Executes files and hyperlinks
423 proc launchBrowser url {
424   global tcl_platform
425
426   if {$tcl_platform(platform) eq "windows"} {
427     set command [list {*}[auto_execok start] {}]
428   } elseif {$tcl_platform(os) eq "Darwin"} {
429       set command [list open]
430     } else {
431         set command [list xdg-open]
432     }
433   exec {*}$command $url &
434 }
435
436 #Safe execution of files and hyperlinks
437 proc _launchBrowser {url} {
438   if [catch {launchBrowser $url} err] {
439     tk_messageBox -icon error -message "error '$err' with '$command'"
440   }
441 }
442 ################################################################
443 # This procedure tries to open an userguide on Draw Harness in pdf format
444 # If there is no a such one, then tries to open it in html format
445 # Else opens a site with this guide
446 ################################################################
447 proc openuserguide {} {
448   if [file exists $::env(CASROOT)/doc/pdf/user_guides/occt_test_harness.pdf] {
449   _launchBrowser $::env(CASROOT)/doc/pdf/user_guides/occt_test_harness.pdf
450   } elseif [file exists $::env(CASROOT)/doc/overview/html/occt_user_guides__test_harness.html] {
451       _launchBrowser $::env(CASROOT)/doc/overview/html/occt_user_guides__test_harness.html
452   } else {
453       _launchBrowser {http://dev.opencascade.org/doc/overview/html/occt_user_guides__test_harness.html}
454     }
455 }
456
457 #Search through commands and display the result
458 proc vhelpsearch {} {
459   global Draw_Groups Entry_Cache
460   set searchstring [.commands.t.top.e get]
461   set i 1
462   set j 100
463   set newgroupinx 0
464   set isfound 0
465   foreach h [lsort [array names Draw_Groups]] {
466   set newgroupinx $j
467     foreach f [lsort $Draw_Groups($h)] {
468       if {$f == $searchstring} {
469         incr isfound
470         .commands.left.tree see  $j
471         .commands.left.tree selection set $j
472         vcomhelp $h $j $newgroupinx
473         break
474       }
475     incr j
476     }
477    incr i
478   }
479   if {$isfound == 0} {
480     errorhelp "No help found for '$searchstring'!"
481   } else {set Entry_Cache ""}
482 }
483
484 #Displays an error window with $errstring inside
485 proc errorhelp {errstring} {
486     toplevel .errorhelp
487     focus .errorhelp
488     wm resizable .errorhelp 0 0
489     wm title .errorhelp "Error"
490     set screenheight [expr {int([winfo screenheight .]*0.5-200)}]
491     set screenwidth [expr {int([winfo screenwidth .]*0.5-200)}]
492     wm geometry .errorhelp +$screenwidth+$screenheight
493     text .errorhelp.t -width 40 -height 5
494     .errorhelp.t insert end $errstring
495     button .errorhelp.button -text "OK" -command "destroy .errorhelp"
496     pack .errorhelp.t
497     .errorhelp.t configure -state disabled
498     pack .errorhelp.button -padx 10 -pady 10
499     bind .errorhelp <Return> {destroy .errorhelp}
500     grab .errorhelp
501 }
502
503 #Search through text of help and display the result
504 proc vhelptextsearch {} {
505   global Draw_Helps Draw_Groups Find_Button_Click_Count Entry_Cache End_of_Search
506   set searchstring [.commands.t.top.e get]
507   if {$Entry_Cache != $searchstring} {
508     set Find_Button_Click_Count 0
509     set End_of_Search 0
510     set Entry_Cache $searchstring
511   }
512   if {$End_of_Search} {
513     errorhelp "No more '$searchstring' found!"
514     return
515   }
516   .commands.t.text configure -state normal
517   .commands.t.text delete 0.0 end
518   set i 0
519   set isfound 0
520   foreach h [lsort [array names Draw_Groups]] {
521     foreach f [lsort $Draw_Groups($h)] {
522       if [string match *$searchstring* $Draw_Helps($f)] {
523         incr i
524         if {$i > $Find_Button_Click_Count+1} {incr isfound; break}
525         .commands.t.text insert end "$f : "
526         foreach line [list $Draw_Helps($f)] {
527           foreach word [split $line " "] {
528             if [string match *$searchstring* $word] {
529               .commands.t.text insert end "$word" "highlightword"
530               .commands.t.text insert end " "
531               continue
532             }
533             .commands.t.text insert end "$word "
534           }
535         }
536       .commands.t.text insert end \n\n
537       }
538     }
539   }
540   if {!$isfound} {
541     incr End_of_Search
542   }
543   .commands.t.text tag configure highlightword -background yellow -relief raised
544   .commands.t.text see end
545 }
546
547 #Create a "System information" window
548 proc sysinfo {} {
549   toplevel .info
550   wm title .info "System information"
551   wm resizable .info 0 0
552   pack [frame .info.top] -side top -fill both -padx 5 -pady 10
553   pack [frame .info.bot] -side bottom -fill both -padx 5 -pady 10
554   pack [frame .info.top.left] -side left -fill both -padx 5 -pady 10
555   pack [frame .info.top.mid] -side left -fill both -padx 5 -pady 10
556   pack [frame .info.top.right] -side left -fill both -padx 5 -pady 10
557   pack [label .info.top.left.label -text "OCCT build configuration "]
558   pack [label .info.top.mid.label -text "Memory info"]
559   pack [label .info.top.right.label -text "OpenGL info"]
560   pack [text .info.top.left.text -width 50 -height 20]
561   pack [text .info.top.mid.text -width 50 -height 20]
562   pack [text .info.top.right.text -width 50 -height 20]
563   pack [button .info.bot.button -text "Update" -command rescaninfo]
564   pack [button .info.bot.close -text "Close" -command "destroy .info"] -pady 10
565   rescaninfo
566 }
567
568 #Updates information in "System information" window
569 proc rescaninfo {} {
570   .info.top.left.text configure -state normal
571   .info.top.mid.text configure -state normal
572   .info.top.right.text configure -state normal
573   .info.top.left.text delete 0.0 end
574   .info.top.mid.text delete 0.0 end
575   .info.top.right.text delete 0.0 end
576   .info.top.left.text insert end [dversion]
577   .info.top.mid.text insert end [meminfo]
578   set glinfo ""
579   if [catch {vglinfo} err] {
580     if {$err == ""} {
581       .info.top.right.text insert end "No active view. Please call vinit."
582     } else {
583         .info.top.right.text insert end "VISUALIZATION is not loaded. Please call pload VISUALIZATION"
584       }
585   } else {
586       .info.top.right.text insert end [vglinfo]
587   }
588   .info.top.left.text configure -state disabled
589   .info.top.mid.text configure -state disabled
590   .info.top.right.text configure -state disabled
591 }