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 trim [string trimleft $line "#Category: "]]
 240       }
 241       if {[lindex [split $line " "] 0] == "#Title:"} {
 242         set atitle [string trim [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 }