0026307: Minor improvements in snowflake sample
[occt.git] / src / DrawResources / DrawTK.tcl
CommitLineData
973c2be1 1# Copyright (c) 1999-2014 OPEN CASCADE SAS
b311480e 2#
973c2be1 3# This file is part of Open CASCADE Technology software library.
b311480e 4#
d5f74e42 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
973c2be1 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.
b311480e 10#
973c2be1 11# Alternatively, this file may be used under the terms of Open CASCADE
12# commercial license or contractual agreement.
b311480e 13
7fd59977 14#
15# TK features for Draw
16#
17
18# reload bindings
19if { [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
ab91ab6f 30#fills menu "Load" with submenus
31proc 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
7fd59977 43wm geometry . +10+10
ab91ab6f 44bind . <F1> {vcommands}
7fd59977 45
46frame .mbar -relief raised -bd 2
47pack .mbar -side top -fill x
48focus .mbar
49
50set theMenus("") ""
51set Draw_MenuIndex 0
52
53proc 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
68proc addmenu {menu submenu {command ""}} {
69 if {$command == ""} {set command $submenu}
ab91ab6f 70 addmenuitem $menu "command -label {$submenu} -command {$command}"
7fd59977 71}
72
73#################################
74# Menus definition
75#################################
76
77# the file menu
78
ab91ab6f 79addmenu File "Choose Data Directory" vdatadir
80addmenu File "Load Shape (restore)" vrestore
81addmenu File "Load Script (source)" vsource
82addmenu File Exit exit
83
84# the Load menu
85fillloadmenu
7fd59977 86
87# the view menu
88
89addmenu Views axo {smallview AXON}
90addmenu Views top {smallview +X+Y}
91addmenu Views front {smallview +X+Z}
92addmenu Views left {smallview +Y+Z}
93addmenu Views 2d {smallview -2D-}
94addmenuitem Views "separator"
95addmenu Views mu4
96addmenu Views av2d
97addmenu Views axo
98addmenu Views pers
99
100# the display menu
101
102addmenu Display fit "fit; repaint"
103addmenu Display 2dfit "2dfit; repaint"
104addmenu Display clear
105addmenu Display 2dclear
106
ab91ab6f 107# the samples menu
108addmenu Samples "View samples" vsample
109
110# the help menu
111
112addmenu Help "System Info" sysinfo
113addmenu Help Commands vcommands
114addmenu Help About about
115addmenu Help "User Guide" openuserguide
116
117#redraw help submenu in the end of menu
118proc 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}
7fd59977 128
129#################################
130# Modal dialog box
ab91ab6f 131# add OK, help, cancel buttons
7fd59977 132#################################
133
134proc modaldialog {box okproc {helpproc ""} {cancelproc ""}} {
135 wm geometry $box +10+60
7fd59977 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
ab91ab6f 147
148#################################
149# File menu procedures
150#################################
151
7fd59977 152##############################
153#
154# dialbox command arg1 val1 arg2 val2 ...
155#
156##############################
157
158proc dialbox args {
7fd59977 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]"
ab91ab6f 185 }
186proc sdatadir {d} {
187 global Draw_DataDir
188 set Draw_DataDir $d
7fd59977 189}
190
ab91ab6f 191proc vdatadir {} {
192 global Draw_DataDir
193 sdatadir [tk_chooseDirectory -title "Data Directory" -initialdir $Draw_DataDir]
194}
7fd59977 195
ab91ab6f 196proc 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
7fd59977 202 }
ab91ab6f 203 }
7fd59977 204}
205
ab91ab6f 206proc vrestore {} {
207 global Draw_DataDir
208 rresto [tk_getOpenFile -title "Load Shape (restore)" -filetypes {{{BREP} {.brep}}} -initialdir $Draw_DataDir]
209}
210
211
212proc ssour {f} {
213 global Draw_Source
214 if {[file exists $f]} {
215 set Draw_Source $f
7fd59977 216 if {! [file isdirectory $f]} {
ab91ab6f 217 puts "source $f [file tail $f]"
218 uplevel \#0 "source $f"
7fd59977 219 }
ab91ab6f 220 }
7fd59977 221}
222
ab91ab6f 223set Draw_Source [pwd]
224proc vsource {} {
225 global Draw_Source
226 ssour [tk_getOpenFile -title "Load Script (source)" -filetypes {{{All Files} *}} -initialdir Draw_Source]
227}
7fd59977 228
ab91ab6f 229#Creates a "Samples" window
230proc 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:"} {
031224c9 239 set acategory [string trim [string trimleft $line "#Category: "]]
ab91ab6f 240 }
241 if {[lindex [split $line " "] 0] == "#Title:"} {
031224c9 242 set atitle [string trim [string trimleft $line "#Title: "]]
ab91ab6f 243 lappend alistofthree $acategory $atitle $fname
244 incr istitlefound
245 break
246 }
7fd59977 247 }
ab91ab6f 248 close $chan
249 if {$istitlefound == 0} {
250 lappend alistofthree Other "[lindex [split $fname \\] end]" $fname
7fd59977 251 }
ab91ab6f 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
7fd59977 286 }
ab91ab6f 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
7fd59977 296}
297
ab91ab6f 298#Fills the textbox in "Samples" window
299proc 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}
7fd59977 310
ab91ab6f 311#Creates a "Commands help" window
312proc 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############################################################
368proc 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}
7fd59977 387
ab91ab6f 388#Creates a "About" window
389proc 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}
7fd59977 421
ab91ab6f 422#Executes files and hyperlinks
423proc launchBrowser url {
424 global tcl_platform
7fd59977 425
ab91ab6f 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 &
7fd59977 434}
435
ab91ab6f 436#Safe execution of files and hyperlinks
437proc _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################################################################
447proc 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}
7fd59977 454 }
7fd59977 455}
456
ab91ab6f 457#Search through commands and display the result
458proc 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
7fd59977 476 }
ab91ab6f 477 incr i
478 }
479 if {$isfound == 0} {
480 errorhelp "No help found for '$searchstring'!"
481 } else {set Entry_Cache ""}
7fd59977 482}
483
ab91ab6f 484#Displays an error window with $errstring inside
485proc 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
7fd59977 501}
502
ab91ab6f 503#Search through text of help and display the result
504proc 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 }
7fd59977 538 }
ab91ab6f 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
7fd59977 545}
546
ab91ab6f 547#Create a "System information" window
548proc 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
569proc 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
7fd59977 591}