1 # Copyright (c) 1999-2014 OPEN CASCADE SAS
3 # This file is part of Open CASCADE Technology software library.
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.
11 # Alternatively, this file may be used under the terms of Open CASCADE
12 # commercial license or contractual agreement.
15 # TK features for Draw
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
26 source $tk_library/tk.tcl
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"
44 bind . <F1> {vcommands}
46 frame .mbar -relief raised -bd 2
47 pack .mbar -side top -fill x
53 proc addmenuitem {menu options} {
55 global theMenus Draw_MenuIndex
56 if {![info exists theMenus($menu)]} {
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
62 set theMenus($menu) $m
63 } else {set m $theMenus($menu)}
68 proc addmenu {menu submenu {command ""}} {
69 if {$command == ""} {set command $submenu}
70 addmenuitem $menu "command -label {$submenu} -command {$command}"
73 #################################
75 #################################
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
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"
102 addmenu Display fit "fit; repaint"
103 addmenu Display 2dfit "2dfit; repaint"
104 addmenu Display clear
105 addmenu Display 2dclear
108 addmenu Samples "View samples" vsample
112 addmenu Help "System Info" sysinfo
113 addmenu Help Commands vcommands
114 addmenu Help About about
115 addmenu Help "User Guide" openuserguide
117 #redraw help submenu in the end of menu
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
129 #################################
131 # add OK, help, cancel buttons
132 #################################
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
148 #################################
149 # File menu procedures
150 #################################
152 ##############################
154 # dialbox command arg1 val1 arg2 val2 ...
156 ##############################
159 set com [lindex $args 0]
164 # com will be the command
167 # create entries for the arguments
168 set n [llength $args]
170 for {set i 1} {$i < $n} {incr i 2} {
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
180 append com { [} ".d.a$i.e get" {]}
182 append com ";repaint"
184 modaldialog .d $com "help [lindex $args 0]"
193 sdatadir [tk_chooseDirectory -title "Data Directory" -initialdir $Draw_DataDir]
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]"
208 rresto [tk_getOpenFile -title "Load Shape (restore)" -filetypes {{{BREP} {.brep}}} -initialdir $Draw_DataDir]
214 if {[file exists $f]} {
216 if {! [file isdirectory $f]} {
217 puts "source $f [file tail $f]"
218 uplevel \#0 "source $f"
223 set Draw_Source [pwd]
226 ssour [tk_getOpenFile -title "Load Script (source)" -filetypes {{{All Files} *}} -initialdir Draw_Source]
229 #Creates a "Samples" window
231 #create list {{category} {title} {filename}}
233 foreach fname [file nativename [glob -path $::env(CASROOT)/samples/tcl/ *]] {
234 if {[lindex [split $fname "."] end] != "tcl"} {continue}
235 set chan [open $fname]
237 while {[gets $chan line] >= 0} {
238 if {[lindex [split $line " "] 0] == "#Category:"} {
239 set acategory [string trim [string trimleft $line "#Category: "]]
241 if {[lindex [split $line " "] 0] == "#Title:"} {
242 set atitle [string trim [string trimleft $line "#Title: "]]
243 lappend alistofthree $acategory $atitle $fname
249 if {$istitlefound == 0} {
250 lappend alistofthree Other "[lindex [split $fname \\] end]" $fname
255 wm title .samples "Samples"
256 wm geometry .samples +0+0
257 wm minsize .samples 800 600
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
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}"
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}"
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
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"
308 .samples.right.textframe.text configure -state disabled
311 #Creates a "Commands help" window
313 global Draw_Groups Find_Button_Click_Count Entry_Cache
314 set Find_Button_Click_Count 0
318 wm minsize .commands 800 600
319 wm title .commands "Commands help"
320 wm geometry .commands +0+0
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
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}"
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"
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
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}
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"
380 .commands.t.text insert end "$f : $Draw_Helps($f)\n\n"
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}
388 #Creates a "About" window
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
419 bind .about <Return> {destroy .about}
422 #Executes files and hyperlinks
423 proc launchBrowser url {
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]
431 set command [list xdg-open]
433 exec {*}$command $url &
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'"
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
453 _launchBrowser {http://dev.opencascade.org/doc/overview/html/occt_user_guides__test_harness.html}
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]
465 foreach h [lsort [array names Draw_Groups]] {
467 foreach f [lsort $Draw_Groups($h)] {
468 if {$f == $searchstring} {
470 .commands.left.tree see $j
471 .commands.left.tree selection set $j
472 vcomhelp $h $j $newgroupinx
480 errorhelp "No help found for '$searchstring'!"
481 } else {set Entry_Cache ""}
484 #Displays an error window with $errstring inside
485 proc errorhelp {errstring} {
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"
497 .errorhelp.t configure -state disabled
498 pack .errorhelp.button -padx 10 -pady 10
499 bind .errorhelp <Return> {destroy .errorhelp}
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
510 set Entry_Cache $searchstring
512 if {$End_of_Search} {
513 errorhelp "No more '$searchstring' found!"
516 .commands.t.text configure -state normal
517 .commands.t.text delete 0.0 end
520 foreach h [lsort [array names Draw_Groups]] {
521 foreach f [lsort $Draw_Groups($h)] {
522 if [string match *$searchstring* $Draw_Helps($f)] {
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 " "
533 .commands.t.text insert end "$word "
536 .commands.t.text insert end \n\n
543 .commands.t.text tag configure highlightword -background yellow -relief raised
544 .commands.t.text see end
547 #Create a "System information" window
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
568 #Updates information in "System information" window
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]
579 if [catch {vglinfo} err] {
581 .info.top.right.text insert end "No active view. Please call vinit."
583 .info.top.right.text insert end "VISUALIZATION is not loaded. Please call pload VISUALIZATION"
586 .info.top.right.text insert end [vglinfo]
588 .info.top.left.text configure -state disabled
589 .info.top.mid.text configure -state disabled
590 .info.top.right.text configure -state disabled