1# 2# This file is part of: 3# 4# gpsman --- GPS Manager: a manager for GPS receiver data 5# 6# Copyright (c) 1998-2013 Miguel Filgueiras migfilg@t-online.de 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either version 3 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program. 20# 21# File: util.tcl 22# Last change: 6 October 2013 23# 24# Includes contributions by Brian Baulch (baulchb _AT_ onthenet.com.au) 25# marked "BSB contribution" 26# 27 28## operations on menus 29 30proc FillMenu {menu commdargs descr} { 31 # entry point for recursive call of FillMenuRec 32 # $menu is the parent menu to fill in 33 # $commdargs is the callback and initial arguments to associate to 34 # each terminal entry; this is treated as a list to which will be 35 # appended the entry and $menu (even on sub-menus) 36 # $descr is a list describing the menu contents as follows: 37 # @ LIST create sub-menu whose label is the head of $LIST, and 38 # whose description is the 2nd and following elements of $LIST 39 # --- insert separator 40 # ENTRY create menu entry 41 # sub-menus will be created when menu length would exceed MAXMENUITEMS 42 43 $menu delete 0 end 44 FillMenuRec $menu $menu $commdargs $descr 45 return 46} 47 48proc FillMenuRec {w menu commdargs descr} { 49 # fill in menus recursively according to description 50 # see proc FillMenu for the meaning of the arguments 51 global MAXMENUITEMS TXT 52 53 set notsub 1 ; set c 1 ; set dl [llength $descr] 54 foreach item $descr { 55 if { $c == $MAXMENUITEMS && $c != $dl } { 56 $menu add cascade -label "$TXT(more) ..." -menu $menu.m$c 57 set menu $menu.m$c ; destroy $menu ; menu $menu -tearoff 0 58 set c 1 ; set dl [expr $dl-$MAXMENUITEMS+1] 59 } 60 if { $notsub } { 61 if { $item != "@" } { 62 if { $item != "---" } { 63 set cmd $commdargs 64 lappend cmd $item $w 65 $menu add command -label $item -command $cmd 66 } else { 67 $menu add separator 68 } 69 } else { 70 set notsub 0 ; incr c -1 ; incr dl -1 71 } 72 } else { 73 set notsub 1 74 set msub $menu.m$c 75 $menu add cascade -label [lindex $item 0] -menu $msub 76 destroy $msub ; menu $msub -tearoff 0 77 FillMenuRec $w $msub $commdargs [lrange $item 1 end] 78 } 79 incr c 80 } 81 return 82} 83 84proc FillMenuExec {menu call args} { 85 # fill in menu with elements of list obtained by executing a command 86 # $call is list to which is appended the selected element and which 87 # will be called when a selection is made 88 # $args will be "eval"-uated to obtain the list 89 # text for each element is the element 90 global MAXMENUITEMS TXT 91 92 if { [winfo exists $menu] } { 93 $menu delete 0 end 94 } 95 set n 0 ; set m 0 96 foreach f [eval $args] { 97 if { $n > $MAXMENUITEMS } { 98 $menu add cascade -label "$TXT(more) ..." -menu $menu.m$m 99 set menu $menu.m$m 100 destroy $menu ; menu $menu -tearoff 0 101 set n 0 ; incr m 102 } 103 $menu add command -label $f -command [linsert $call end $f] 104 incr n 105 } 106 return 107} 108 109proc FillPFormtMenu {menu comm args} { 110 # fill in menu with possible position formats 111 # $comm is command to call with selected format followed by each of 112 # $args except the first one 113 # $args is a list whose first element is a list of formats not 114 # to be shown; the other elements are arguments to $comm 115 global GRIDS TXT MAXMENUITEMS NONGRIDFMTS 116 117 if { [winfo exists $menu] } { 118 $menu delete 0 end 119 } 120 set n 0 ; set m 0 121 # $GRIDS may change dynamically 122 set fmts [concat $NONGRIDFMTS $GRIDS] 123 foreach f [lindex $args 0] { 124 if { [set i [lsearch -exact $fmts $f]] != -1 } { 125 set fmts [lreplace $fmts $i $i] 126 } 127 } 128 foreach f $fmts { 129 if { $n > $MAXMENUITEMS } { 130 $menu add cascade -label "$TXT(more) ..." -menu $menu.m$m 131 set menu $menu.m$m 132 destroy $menu ; menu $menu -tearoff 0 133 set n 0 ; incr m 134 } 135 $menu add command -label $TXT($f) \ 136 -command [concat [list $comm $f] [lreplace $args 0 0]] 137 incr n 138 } 139 return 140} 141 142### positions 143 144proc FillPos {w pformt posns state chgvorp} { 145 # create widgets to display positions 146 # $w is path to either an empty frame where a single position in 147 # lists $posns is to be displayed, or to frame that will contain 148 # frames with widgets for each position in $posns 149 # $pformt is the position format (see array POSTYPE, projections.tcl) 150 # $posns is a list of positions (see proc FormatPosition, compute.tcl) 151 # $state in {normal, disabled} 152 # $chgvorp is either "nil" or: 153 # - if there is a single position, the name of global variable to 154 # set to 1 if the user types in any entry and that contains the 155 # current position otherwise; see procs ChangePFormt and 156 # PosnGetCheckEmpty 157 # - else, "=PREFIX" describing global variables used in the same 158 # way for each position; each name has the prefix followed by the 159 # number from 1 of the position 160 # the widgets for each position are created under frames $w.frp$i where $i 161 # is the order from 1 162 # the frames $w.frp1, $w.frp2, ... are created and packed from top if 163 # they do not exist 164 global TXT POSTYPE 165 166 switch $POSTYPE($pformt) { 167 latlong { 168 set ns [list $TXT(lat) $TXT(long)] 169 set fs "lat long" ; set ws "12 12" 170 } 171 utm { 172 set ns [list $TXT(ze) $TXT(zn) $TXT(eastng) $TXT(nrthng)] 173 set fs "ze zn eng nng" ; set ws "3 3 8 8" 174 } 175 grid { 176 set ns [list $TXT(zone) $TXT(eastng) $TXT(nrthng)] 177 set fs "zn eng nng" ; set ws "5 8 8" 178 } 179 nzgrid { 180 set ns [list $TXT(eastng) $TXT(nrthng)] 181 set fs "eng nng" ; set ws "8 8" 182 } 183 mh { 184 set ns "" ; set fs mh ; set ws 8 185 } 186 } 187 if { [winfo children $w] == "" } { 188 # single position, repopulate $w 189 FillEntries $w $fs $ns $ws [lrange [lindex $posns 0] 2 end] $state \ 190 $chgvorp 191 return 192 } 193 set n 1 194 if { [regsub {^=} $chgvorp "" prefix] } { 195 set nvar 1 196 } else { set nvar 0 ; set chgvar $chgvorp } 197 foreach posn $posns { 198 set wf $w.frp$n 199 if { ! [winfo exists $wf] } { 200 frame $wf 201 pack $wf -side top 202 } 203 set ep [lrange $posn 2 end] 204 if { $nvar } { set chgvar ${prefix}$n } 205 FillEntries $wf $fs $ns $ws $ep $state $chgvar 206 incr n 207 } 208 return 209} 210 211proc PosnGetCheck {w datum errproc chgvar} { 212 # get and check position in edit/show window 213 # $w is path to parent window of position widgets, whose parent 214 # contains the widget for the position format 215 # $errproc is procedure to call on error 216 # $chgvar is either "nil" or name of global variable to set to 217 # 1 if the user types in any entry and that contains the 218 # current position otherwise 219 # returns "nil" on error or if there are empty fields 220 global MESS 221 222 if { [set r [PosnGetCheckEmpty $w $datum $errproc $chgvar]] == \ 223 "empty" } { 224 $errproc $MESS(emptypos) 225 return nil 226 } 227 return $r 228} 229 230proc PosnGetCheckEmpty {w datum errproc chgvar} { 231 # get and check position in edit/show window 232 # $w is path to parent window of position widgets, whose parent 233 # contains the widget for the position format 234 # $errproc is procedure to call on error 235 # $chgvar is either "nil" or name of global variable to set to 236 # 1 if the user types in any entry and that contains 237 # the current position otherwise (possibly "") 238 # returns "empty" if there are empty fields, and "nil" on error 239 global MESS INVTXT POSTYPE 240 241 if { $chgvar != "nil" } { 242 global $chgvar 243 244 if { [set p [set $chgvar]] == "" } { return empty } 245 if { $p != 1 } { return $p } 246 } 247 set wp [winfo parent $w] 248 set pf $INVTXT([$wp.pfmt cget -text]) 249 switch [set ptype $POSTYPE($pf)] { 250 latlong { 251 set wlat [$w.lat get] ; set wlong [$w.long get] 252 if { $wlat == "" && $wlong == "" } { return empty } 253 if { [CheckLat $errproc $wlat $pf] && \ 254 [CheckLong $errproc $wlong $pf] } { 255 set latdeg [Coord $pf $wlat S] 256 set longdeg [Coord $pf $wlong W] 257 set p [list $latdeg $longdeg $wlat $wlong] 258 } else { return nil } 259 } 260 utm { 261 foreach m "ze zn eng nng" c "ZE ZN Number Number" { 262 set $m [$w.$m get] 263 if { [set $m] == "" } { 264 return empty 265 } elseif { ! [Check$c $errproc [set $m]] } { return nil } 266 } 267 if { $eng != 0 } { set eng [string trimleft $eng "0"] } 268 if { $nng != 0 } { set nng [string trimleft $nng "0"] } 269 set pd [UTMToDegrees $ze $zn $eng $nng $datum] 270 set p [list [lindex $pd 0] [lindex $pd 1] $ze $zn $eng $nng] 271 } 272 grid - 273 nzgrid { 274 foreach m "eng nng" { 275 set $m [$w.$m get] 276 if { [set $m] == "" } { 277 return empty 278 } elseif { ! [CheckFloat $errproc [set $m]] } { return nil } 279 } 280 if { $eng != 0 } { set eng [string trimleft $eng "0"] } 281 if { $nng != 0 } { set nng [string trimleft $nng "0"] } 282 if { $ptype == "grid" } { 283 set gr 1 284 set zn [$w.zn get] 285 if { ! [CheckZone $errproc $zn $pf] } { 286 if { $zn == "" } { return empty } 287 return nil 288 } 289 } else { set gr 0 ; set zn "" } 290 if { [BadDatumFor $pf $datum GMMessage] != 0 } { return nil } 291 set p [GridToDegrees $pf $zn $eng $nng $datum] 292 if { $p == 0 } { 293 $errproc $MESS(outofgrid) 294 return nil 295 } 296 if { $gr } { 297 lappend p $zn $eng $nng 298 } else { lappend p $eng $nng } 299 } 300 mh { 301 set mh [string trim [$w.mh get] " "] 302 if { $mh == "" } { return empty } 303 if { ! [CheckMHLocator $errproc $mh] } { return nil } 304 set p [linsert [MHLocToDegrees $mh] end $mh] 305 } 306 } 307 if { $chgvar != "nil" } { 308 global $chgvar 309 310 set $chgvar $p 311 } 312 return $p 313} 314 315proc RevertPos {w pformt ptype posn} { 316 # change position values keeping its format 317 # $w is path to parent window of position widgets, whose parent 318 # contains the widget for the position format 319 # $pformt is position format (see projections.tcl) 320 # $ptype is type of position format (see array POSTYPE, projections.tcl) 321 # $posn is the position (see proc FormatPosition, compute.tcl) 322 global TXT 323 324 [winfo parent $w].pfmt configure -text $TXT($pformt) 325 switch $ptype { 326 latlong { 327 set bs {lat long} ; set is {2 3} 328 } 329 utm { 330 set bs {ze zn eng nng} ; set is {2 3 4 5} 331 } 332 grid { 333 set bs {zn eng nng} ; set is {2 3 4} 334 } 335 nzgrid { 336 set bs {eng nng} ; set is {2 3} 337 } 338 mh { 339 set bs mh ; set is 2 340 } 341 } 342 set st [$w.[lindex $bs 0] cget -state] 343 foreach b $bs k $is { 344 $w.$b configure -state normal 345 $w.$b delete 0 end 346 $w.$b insert 0 [lindex $posn $k] 347 $w.$b configure -state $st 348 } 349 return 350} 351 352proc RedrawPos {w pformt posn chgvar st} { 353 # display position under a new format 354 # $w is path to parent window of position widgets, whose parent 355 # contains the widget for the position format 356 # $pformt is the new format (see projections.tcl) 357 # $posn is the position (see proc FormatPosition, compute.tcl) 358 # $chgvar is either "nil" or name of global variable to set to 359 # 1 if the user types in any entry and that contains the 360 # current position otherwise (possibly "") 361 # $st is state for position widgets 362 global TXT 363 364 foreach s [winfo children $w] { destroy $s } 365 FillPos $w $pformt [list $posn] $st $chgvar 366 return 367} 368 369proc ChangePFormt {pformt dvar dvref w chgvorp st} { 370 # change format of positions in window 371 # $w is path to parent window containing frp$i sub-frames for 372 # each position with $i an integer from 1 373 # $pformt is position format (see array POSTYPE, projections.tcl) 374 # $chgvorp is either "nil" or: 375 # - if there is a single position, the name of global variable to 376 # set to 1 if the user types in any entry and that contains the 377 # current position otherwise; see procs ChangePFormt and 378 # PosnGetCheckEmpty 379 # - else, "=PREFIX" describing global variables used in the same 380 # way for each position; each name has the prefix followed by the 381 # number from 1 of the position 382 # $dvar is name of global variable or array for datum 383 # $dvref is name of variable or array(element) for datum 384 # $st is state of the position widgets 385 global INVTXT $dvar MESS POSTYPE TXT 386 387 set opf $INVTXT([$w.pfmt cget -text]) 388 if { $opf == $pformt } { return } 389 set datum [set $dvref] 390 if { [set ndatum [BadDatumFor $pformt $datum Ignore]] == 0 } { 391 set ndatum $datum 392 } 393 if { [regsub {^=} $chgvorp "" prefix] } { 394 set nvar 1 395 } else { set nvar 0 ; set chgvar $chgvorp } 396 set frs "" ; set posns "" 397 foreach fr [winfo children $w] { 398 if { [regexp {\.frp([0-9]+)$} $fr x n] } { 399 lappend frs $fr 400 if { $nvar } { set chgvar ${prefix}$n } 401 set p [PosnGetCheckEmpty $fr $datum GMMessage $chgvar] 402 if { $p == "nil" } { return } 403 if { $p == "empty" } { 404 set p "" 405 } else { 406 set p [lindex \ 407 [FormatPosition [lindex $p 0] [lindex $p 1] $datum \ 408 $pformt ""] 0] 409 if { [lindex $p 2] == "--" } { 410 GMMessage $MESS(outofgrid) 411 return 412 } 413 } 414 lappend posns $p 415 } 416 } 417 set ot $POSTYPE($opf) ; set nt $POSTYPE($pformt) 418 foreach fr $frs np $posns { 419 if { $chgvorp != "nil" } { 420 if { $nvar } { set chgvar ${prefix}$n } 421 global $chgvar 422 423 set $chgvar $np 424 } 425 if { $ot == $nt } { 426 RevertPos $fr $pformt $nt $np 427 } else { 428 RedrawPos $fr $pformt $np $chgvar $st 429 } 430 } 431 set $dvref $ndatum 432 $w.pfmt configure -text $TXT($pformt) 433 return 434} 435 436proc ChangeDatum {datum dvar dvref chgvorp posfr st} { 437 # change datum 438 # $posfr is path to parent window containing frp$i sub-frames for 439 # each position with $i an integer from 1 440 # see proc ChangePFormt for the meaning of the other arguments 441 global $dvar INVTXT MESS POSTYPE 442 443 set olddatum [set $dvref] 444 if { $olddatum == $datum } { return } 445 set pformt $INVTXT([$posfr.pfmt cget -text]) 446 if { [BadDatumFor $pformt $datum GMMessage] != 0 } { 447 return 448 } 449 if { [regsub {^=} $chgvorp "" prefix] } { 450 set nvar 1 451 } else { set nvar 0 ; set chgvar $chgvorp } 452 foreach fr [winfo children $posfr] { 453 if { [regexp {\.frp([0-9]+)$} $fr x n] } { 454 if { $nvar } { set chgvar ${prefix}$n } 455 set op [PosnGetCheck $fr $olddatum Ignore $chgvar] 456 if { $op != "nil" } { 457 set np [lindex [FormatPosition [lindex $op 0] [lindex $op 1] \ 458 $olddatum $pformt $datum] 0] 459 RevertPos $fr $pformt $POSTYPE($pformt) $np 460 if { $chgvar != "nil" } { 461 global $chgvar 462 463 set $chgvar $np 464 } 465 } 466 } 467 } 468 set $dvref $datum 469 return 470} 471 472## directory listing 473 474proc FillDir {w} { 475 # fill in listbox $w with files in a directory 476 # insert "../" at the beginning, followed by sub-directories 477 # and then ordinary files 478 479 set dl "" ; set fl "" 480 foreach f [lsort [glob -nocomplain *]] { 481 if { [file isdirectory $f] } { 482 set dl [linsert $dl 0 $f] 483 } else { 484 set fl [linsert $fl 0 $f] 485 } 486 } 487 foreach f $fl { $w insert 0 $f } 488 foreach d $dl { $w insert 0 "$d/" } 489 $w insert 0 "../" 490 return 491} 492 493## operations on windows 494 495proc CloseWindows {ws} { 496 # close windows using their specific WM_DELETE_WINDOW command if any 497 498 foreach w $ws { 499 if { [winfo exists $w] } { 500 if { [set c [wm protocol $w WM_DELETE_WINDOW]] != "" } { 501 catch {eval $c} 502 } else { destroy $w } 503 } 504 } 505 return 506} 507 508proc DestroyRGrabs {w oldgrabs} { 509 # destroy window $w and restore previous grabs 510 511 destroy $w 512 foreach w $oldgrabs { 513 if { [winfo exists $w] } { grab $w } 514 } 515 return 516} 517 518proc Raise {w} { 519 520 raise $w ; focus $w 521 return 522} 523 524proc RaiseWindow {w} { 525 # keep a window on top 526 # CANNOT BE USED for windows that create menus: they will disappear! 527 global WindowStack 528 529 if { [winfo exists $w] } { 530 raise $w 531 if { $WindowStack == "" } { after 2000 RaiseWindowStack } 532 set WindowStack [linsert $WindowStack 0 $w] 533 update idletasks 534 } 535 return 536} 537 538proc RaiseWindowStack {} { 539 # keep a window on top if it is on top of the stack 540 global WindowStack 541 542 while { $WindowStack != "" } { 543 if { [winfo exists [set w [lindex $WindowStack 0]]] } { 544 raise $w 545 after 2000 RaiseWindowStack 546 update idletasks 547 break 548 } else { 549 set WindowStack [lreplace $WindowStack 0 0] 550 } 551 } 552 return 553} 554 555proc ToggleWindow {w x y} { 556 # from normal to iconic and back (with geometry +$x+$y) 557 # in fact, because some window managers do not iconify windows 558 # just put them at large 559 # in fact, because some window managers do not even deal correctly 560 # with putting windows at large, just raise them... 561 # ... and try to de-iconify them if they are icons 562 global MESS 563 564 if { [winfo exists $w] } { 565 if { [wm state $w] == "iconic" } { 566 wm deiconify $w ; wm geometry $w +$x+$y 567 } 568 raise $w 569 } else { 570 GMMessage $MESS(windowdestr) 571 } 572# switch [wm state $w] { 573# normal { 574# # wm iconify $w 575# set g [winfo geometry $w] 576# if { [regexp {[0-9]+x[0-9]+\+(-?[0-9]+)\+-?[0-9]+} $g z cx] } { 577# if { $cx < 0 } { 578# wm geometry $w +$x+$y 579# raise $w ; focus $w 580# } else { 581# wm geometry $w +-10000+-10000 582# } 583# } else { 584# GMMessage "Bad result from winfo geometry $w: $g" 585# } 586# } 587# iconic { 588# wm deiconify $w ; wm geometry $w +$x+$y 589# } 590# withdrawn { bell } 591# } 592 return 593} 594 595## changing state of interface 596 597proc ChangeOnState {what st} { 598 # change state of some widgets according to specification in WConf array 599 # $what is index in WConf array 600 # $st in {normal, disabled} 601 # entries of WConf used here are lists of lists; information in each 602 # sublist depends on its 1st element: 603 # menu - 2nd element is a list of pairs with menu path and list of 604 # entries 605 # button (or menubutton) - 2nd element is list of paths 606 global WConf CMDLINE 607 608 if { $CMDLINE } { return } 609 foreach p $WConf($what) { 610 switch [lindex $p 0] { 611 menu { 612 foreach m [lindex $p 1] { 613 set w [lindex $m 0] 614 foreach e [lindex $m 1] { 615 $w entryconfigure $e -state $st 616 } 617 } 618 } 619 button - menubutton { 620 foreach b [lindex $p 1] { 621 $b configure -state $st 622 } 623 } 624 } 625 } 626 return 627} 628 629## operations on entries 630 631proc CheckEntries {errproc errval descr} { 632 # check values given on entries 633 # $errproc proc to be called on error 634 # $descr is a list of pairs or triplets with: 635 # - path to the entry 636 # - procedure to be called for checking the data, 637 # with the following arguments: 638 # - $errproc 639 # - the contents of the entry 640 # - the argument to checking procedure if it exists 641 # - argument to checking procedure (optional) 642 # return list with contents of entries, or $errval on error 643 644 set r "" 645 foreach item $descr { 646 set w [lindex $item 0] ; set p [lindex $item 1] 647 set a [lrange $item 2 end] 648 set info [$w get] 649 if { $a != "" } { 650 set ok [$p $errproc $info $a] 651 } else { set ok [$p $errproc $info] } 652 if { $ok } { 653 lappend r $info 654 } else { 655 focus $w 656 return $errval 657 } 658 } 659 return $r 660} 661 662proc FillEntries {w names titles widths vals state chgvar} { 663 # create and fill a set of entries under window $w 664 # $names is a list of names for the widgets 665 # $titles is associated list of titles to show as labels 666 # $widths is associated list of widths 667 # $vals is associated list of initial values 668 # $state in {normal, disabled} 669 # $chgvar is either "" or name of global variable to set to 670 # 1 if the user types or pastes in any entry 671 672 foreach n $names t $titles l $widths v $vals { 673 if { $n == "" } { return } 674 label $w.${n}title -text "$t:" 675 entry $w.$n -width $l -exportselection 1 676 $w.$n insert 0 $v 677 TextBindings $w.$n 678 if { $state == "normal" && $chgvar != "" } { 679 bind $w.$n <Any-Key> "set $chgvar 1" 680 bind $w.$n <Any-ButtonRelease> "set $chgvar 1" 681 } 682 $w.$n configure -state $state 683 pack $w.${n}title $w.$n -side left -padx 3 684 } 685 return 686} 687 688proc ShowTEdit {entry string flag} { 689 # show a string on an entry 690 # enable edition and set text bindings according to $flag 691 692 $entry configure -state normal 693 $entry delete 0 end ; $entry insert 0 $string 694 if { $flag } { 695 TextBindings $entry 696 } else { 697 $entry configure -state disabled 698 } 699 return 700} 701 702## operations on text 703 704proc TextCheckLimit {txt max bgix errbgix} { 705 # change the background of text characters that are beyond the 706 # given number of characters 707 # $bgix is the normal background index in COLOUR array 708 # $errbgix is the error background index in COLOUR array 709 # a tag "ob" is used for this 710 global COLOUR 711 712 $txt tag delete ob 713 set max "1.0+$max chars" 714 if { [$txt compare end > $max] } { 715 $txt tag add ob $max end 716 $txt tag configure ob -background $COLOUR($errbgix) 717 } else { $txt configure -background $COLOUR($bgix) } 718 return 719} 720 721## operations on data 722 723proc CompareVals {arr i j} { 724 # compare as strings two array elements 725 global $arr 726 727 return [string compare "[set [set arr]($i)]" "[set [set arr]($j)]"] 728} 729 730proc MergeData {list ps vs} { 731 # put the values $vs into $list in positions $ps 732 # empty elements will be created if positions extend the list 733 734 set l [llength $list] 735 foreach p $ps v $vs { 736 while { $p >= $l } { 737 lappend list "" 738 incr l 739 } 740 set list [lreplace $list $p $p $v] 741 } 742 return $list 743} 744 745proc MakeSplit {lls ixs} { 746 # split a list of lists into lists of lists according to the given 747 # indices 748 749 set rs "" 750 set del 0 751 while 1 { 752 if { $ixs == "" } { 753 lappend rs $lls 754 break 755 } 756 set void 1 757 set ixn [expr [lindex $ixs 0]-$del] ; set ixs [lreplace $ixs 0 0] 758 incr del $ixn 759 set sl "" ; set rsl "" 760 foreach l $lls { 761 lappend sl [lrange $l 0 [expr $ixn-1]] 762 if { [set sll [lrange $l $ixn end]] != "" } { set void 0 } 763 lappend rsl $sll 764 } 765 lappend rs $sl 766 if { $void } { break } 767 set lls $rsl 768 } 769 return $rs 770} 771 772proc Delete {l x} { 773 # return list obtained from $l by deleting $x 774 775 if { [set ix [lsearch -exact $l $x]] != -1 } { 776 return [lreplace $l $ix $ix] 777 } 778 return $l 779} 780 781proc Subtract {l1 l2} { 782 # return list obtained from $l1 by deleting all elements in $l2 783 784 foreach x $l2 { 785 if { [set ix [lsearch -exact $l1 $x]] != -1 } { 786 set l1 [lreplace $l1 $ix $ix] 787 } 788 } 789 return $l1 790} 791 792proc Intersect1 {l1 l2} { 793 # return first common element in both lists or empty list if none 794 795 foreach e $l1 { 796 if { [lsearch -exact $l2 $e] != -1 } { return $e } 797 } 798 return "" 799} 800 801proc ListReplace {l olds news} { 802 # replace in list $l any ocurrences of elements of list $olds 803 # by the aligned elements of list $news 804 # $l may have repeated elements 805 # return pair with flag set if there were replacements and resulting 806 # list 807 808 set chg 0 809 foreach o $olds n $news { 810 foreach i [lsearch -exact -all $l $o] { 811 set l [lreplace $l $i $i $n] 812 incr chg 813 } 814 } 815 return [list $chg $l] 816} 817 818proc FindArrayIndices {array val errix} { 819 # check that $val is an element of $array (possibly with repeated values) 820 # return indices of $val on success and $errix on error 821 global $array 822 823 set l "" ; set n 0 824 foreach an [array names $array] { 825 if { [set [set array]($an)] == $val } { 826 lappend l $an ; set n 1 827 } 828 } 829 if { $n } { return $l } 830 return $errix 831} 832 833proc AssignGlobal {var val} { 834 # assign $val to global $var 835 global $var 836 837 set $var $val 838 return 839} 840 841## hiding and showing columns of objects in a grid 842 843proc CollapseColumn {objs col label type args} { 844 # collapse column $col of objects $objs in a frame managed as grid 845 # and create an object to restore it 846 # $objs must be list of all objects ordered by row (from 0) 847 # $label is title for the new object 848 # $type describes what is the new object and $args: 849 # ==button, $args=="$fr $orient" where 850 # $fr is frame (managed as grid) parent of new button 851 # $orient in {row, col} is how the buttons are shown in $fr 852 # - a label $fr.title is assumed to be the first element of 853 # the row/column 854 # ==menubtentry, $args=="$menu $menubutton" 855 # $menubutton must enabled if it is disabled 856 857 foreach o $objs { grid forget $o } 858 switch $type { 859 button { 860 set fr [lindex $args 0] 861 set sls [grid slaves $fr] 862 if { [set n [llength $sls]] == 0 } { 863 grid configure $fr.title -row 0 -column 0 -sticky news 864 set n 1 865 } 866 set b $fr.b$col 867 if { [winfo exists $b] } { 868 if { [lsearch -exact $sls $b] != -1 } { return } 869 } else { 870 button $b -text $label -command \ 871 [list ShowColumn $objs $col $type $fr $b] 872 } 873 if { [lindex $args 1] == "col" } { 874 set r $n ; set c 0 875 } else { set r 0 ; set c $n } 876 grid configure $b -row $r -column $c -sticky news 877 } 878 menubtentry { 879 set menu [lindex $args 0] ; set menubutton [lindex $args 1] 880 if { [$menubutton cget -state] == "disabled" } { 881 $menubutton configure -state normal 882 } 883 $menu add command -label $label -command \ 884 [list ShowColumn $objs $col $type $menu $menubutton $label] 885 } 886 } 887 return 888} 889 890proc ShowColumn {objs col type args} { 891 # show column $col of objects $objs in a frame managed as grid and 892 # hide/delete object that invoked this command 893 # $objs, $type as in proc CollapseColumn 894 # $type==button, $args=="$fr $button" 895 # if frame has a single slave (assumed to be $fr.title) it is hidden 896 # $type==menubtentry, $args=="$menu $menubutton $label" 897 # if menu becomes empty, menubutton is disabled 898 899 set r 0 900 foreach o $objs { 901 grid configure $o -row $r -column $col -sticky news 902 incr r 903 } 904 switch $type { 905 button { 906 grid forget [lindex $args 1] 907 set fr [lindex $args 0] 908 if { [grid slaves $fr] == $fr.title } { 909 grid forget $fr.title 910 } 911 } 912 menubtentry { 913 set menu [lindex $args 0] ; set menubutton [lindex $args 1] 914 set label [lrange $args 2 end] 915 set n [$menu index last] 916 for { set ix 0 } { $ix <= $n } { incr ix } { 917 if { [$menu entrycget $ix -label] == $label } { 918 $menu delete $ix 919 if { $ix+$n == 0 } { 920 $menubutton configure -state disabled 921 } 922 break 923 } 924 } 925 } 926 } 927 return 928} 929 930## selecting in and scrolling listboxes 931 932proc MultSelect {w ix bxs} { 933 # select only one element at index $ix in each listbox in $bxs 934 # with $w the parent window 935 foreach l $bxs { 936 $w.$l selection clear 0 end 937 $w.$l selection set $ix 938 } 939 return 940} 941 942proc MultExtSelect {bx bxs} { 943 # adjust extended selection in each listbox in $bxs that are siblings 944 # of $bx 945 946 set s [$bx curselection] 947 set w [winfo parent $bx] 948 foreach l $bxs { 949 if { $l != $bx } { 950 $w.$l selection clear 0 end 951 foreach ix $s { $w.$l selection set $ix } 952 } 953 } 954 return 955} 956 957proc ScrollListIndex {box char} { 958 # scroll listbox so that first element with initial >= $char is shown 959 # this is case sensitive! 960 # if none found, scroll to end 961 962 if { $char == "" } { return } 963 set i 0 964 foreach e [$box get 0 end] { 965 if { [string compare $char [string range $e 0 0]] <= 0 } { 966 $box see $i 967 return 968 } 969 incr i 970 } 971 $box see end 972 return 973} 974 975proc ScrollMany {boxs args} { 976 977 foreach b $boxs { 978 eval $b yview $args 979 } 980 return 981} 982 983# BSB contribution: support for wheelmouse scrolling of listboxes 984proc Mscroll {boxes} { 985 986 foreach b $boxes { 987 bind $b <Button-5> " ScrollMany [list $boxes] scroll 5 units " 988 bind $b <Button-4> " ScrollMany [list $boxes] scroll -5 units " 989 bind $b <Shift-Button-5> " ScrollMany [list $boxes] scroll 1 units " 990 bind $b <Shift-Button-4> " ScrollMany [list $boxes] scroll -1 units " 991 bind $b <Control-Button-5> " ScrollMany [list $boxes] scroll 1 pages " 992 bind $b <Control-Button-4> " ScrollMany [list $boxes] scroll -1 pages " 993 } 994 return 995} 996 997## balloon help (mostly adapted from macau, by the same author) 998 999proc BalloonBindings {wci lst} { 1000 # set bindings for balloon help 1001 # $wci either a window path or a list with canvas path and item or tag 1002 # $lst is list of args needed for the call to proc BalloonCreate 1003 1004 if { [llength $wci] == 1 } { 1005 bind $wci <Enter> [list Balloon $lst] 1006 bind $wci <Motion> { BalloonMotion %X %Y } 1007 bind $wci <Leave> BalloonDestroy 1008 } else { 1009 set cv [lindex $wci 0] ; set it [lindex $wci 1] 1010 $cv bind $it <Enter> [list Balloon $lst] 1011 $cv bind $it <Motion> { BalloonMotion %X %Y } 1012 $cv bind $it <Leave> BalloonDestroy 1013 } 1014 return 1015} 1016 1017proc BalloonButton {path lst} { 1018 # create button with given $path to display a balloon help 1019 # $lst is list of args needed for the call to proc BalloonCreate 1020 # return $path 1021 global SYMBOLIMAGE 1022 1023 button $path -image $SYMBOLIMAGE(interr) \ 1024 -command "BalloonCreate 12000 $lst" 1025 bind $path <Motion> { BalloonMotion %X %Y } 1026 bind $path <Enter> BalloonDestroy 1027 return $path 1028} 1029 1030proc Balloon {lst} { 1031 global BalloonStart BalloonHelp 1032 1033 if { $BalloonHelp } { 1034 set BalloonStart [after 2000 "BalloonCreate 10000 $lst"] 1035 } 1036 return 1037} 1038 1039proc NewBalloon {blln mess geom} { 1040 1041 global COLOUR 1042 1043 destroy $blln 1044 toplevel $blln 1045 wm resizable $blln 0 0 1046 wm overrideredirect $blln 1 1047 wm geometry $blln $geom 1048 wm group $blln . 1049 label $blln.mess -text $mess -relief groove -bg $COLOUR(ballbg) \ 1050 -fg $COLOUR(ballfg) 1051 pack $blln.mess 1052 return 1053} 1054 1055proc BalloonCreate {timeout args} { 1056 # $timeout is either 0 or msecs to destroy balloon help 1057 global BalloonX BalloonY BalloonEnd TXT COLOUR 1058 1059 switch -glob -- [set a0 [lindex $args 0]] { 1060 =* { 1061 set mess [string range $a0 1 end] 1062 } 1063 default { 1064 if { [catch [list set mess $TXT($a0)]] } { 1065 set mess $TXT(nohelp) 1066 } 1067 } 1068 } 1069 NewBalloon .balloon $mess +$BalloonX+$BalloonY 1070 if { $timeout } { 1071 set BalloonEnd [after $timeout "destroy .balloon"] 1072 } else { set BalloonEnd "" } 1073 return 1074} 1075 1076proc BalloonMotion {x y} { 1077 global BalloonX BalloonY 1078 1079 set BalloonX [expr $x+9] ; set BalloonY [expr $y+9] 1080 if { [winfo exists .balloon] } { 1081 wm geometry .balloon +$BalloonX+$BalloonY 1082 } 1083 return 1084} 1085 1086proc BalloonDestroy {} { 1087 global BalloonStart BalloonEnd 1088 1089 catch {after cancel $BalloonStart} 1090 catch {after cancel $BalloonEnd} 1091 destroy .balloon 1092 return 1093} 1094 1095## double-click or qualified single-click vs. single-click bindings 1096 1097# avoid compound clicks being taken as a single-click followed 1098# by some other event 1099 1100# usage in bindings, as in: 1101# bind TAG <Button-1> { SafeSingleClick 1 MYCOMMAND1 ARG1 ... ARGn } 1102# bind TAG <Double-1> { SafeCompoundClick 1 MYCOMMAND2 ARG1 ... ARGk } 1103 1104array set SafeClick { 1105 delay,1 300 job,1 "" time,1 1e77 1106 delay,2 300 job,2 "" time,2 1e77 1107 delay,3 300 job,3 "" time,3 1e77 1108} 1109 1110proc SafeSingleClick {button comm args} { 1111 # delay effect of single-click so that it may be cancelled by 1112 # a compound-click binding 1113 # $button in {1, 2, 3} (see initialization of SafeClick array) 1114 # $comm is the command to be executed in answer to the single-click 1115 # $args are the arguments to this command if any 1116 # the following global array is used 1117 # $SafeClick(job,$button) has the job id to be cancelled 1118 # $SafeClick(delay,$button) is the delay in ms 1119 # $SafeClick(time,$button) is the time of last compound-click if any 1120 global SafeClick 1121 1122 if { abs([clock clicks -milliseconds]-$SafeClick(time,$button)) < \ 1123 $SafeClick(delay,$button) } { return } 1124 set SafeClick(time,$button) 1e77 1125 set SafeClick(job,$button) \ 1126 [after $SafeClick(delay,$button) eval $comm $args] 1127 return 1128} 1129 1130proc SafeCompoundClick {button comm args} { 1131 # cancel effect of single-click before executing command (normally 1132 # as a result of a compound-click) 1133 # $comm is the command to be executed in answer to the single-click 1134 # $args are the arguments to this command if any 1135 # the same global var as in proc SafeSingleClick is used 1136 global SafeClick 1137 1138 after cancel $SafeClick(job,$button) 1139 set SafeClick(time,$button) [clock clicks -milliseconds] 1140 eval $comm $args 1141 return 1142} 1143 1144## canvas 1145 1146proc TurnObject {trk data} { 1147 # turn canvas object $trk degrees from vertical north 1148 # $data is list with coordinates of rotation centre (x_m, y_m), 1149 # tag of object, canvas path and list of coordinates relative to 1150 # (x_m, y_m) 1151 1152 foreach "xm ym tag cv cs0" $data {} 1153 set rad [expr $trk*0.01745329251994329576] 1154 set cos [expr cos($rad)] ; set sin [expr sin($rad)] 1155 set cs "" 1156 foreach "x y" $cs0 { 1157 lappend cs [expr round($xm+$x*$cos+$y*$sin)] \ 1158 [expr round($ym-$x*$sin+$y*$cos)] 1159 } 1160 eval $cv coords $tag $cs 1161 update idletasks 1162 return 1163} 1164 1165proc CanvasChangeFont {cv v vref} { 1166 # change font in canvas using proc GMSelectFont 1167 # $v is name to declare as global 1168 # $vref is reference to set (variable name or array and index) 1169 # all canvas items with tag txt will be reconfigured 1170 global $v TkDefaultFont 1171 1172 if { [set f [GMSelectFont $TkDefaultFont]] == {} } { return } 1173 set $vref $f 1174 foreach it [$cv find withtag txt] { 1175 $cv itemconfigure $it -font $f 1176 } 1177 return 1178} 1179 1180## varia 1181 1182proc Measure {text} { 1183 # length of a string plus 2 1184 1185 return [expr 2+[string length $text]] 1186} 1187 1188proc Apply {list f args} { 1189 # apply proc $f to each element of list 1190 # $f is called with arguments $args and list element 1191 1192 set r "" 1193 foreach i $list { 1194 lappend r [$f $args $i] 1195 } 1196 return $r 1197} 1198 1199proc Undefined {list} { 1200 # test whether there is a -1 in list 1201 1202 foreach i $list { 1203 if { $i == -1 } { return 1 } 1204 } 1205 return 0 1206} 1207 1208proc Complement {u l} { 1209 # compute the complement to list $u of list $l 1210 1211 foreach x $l { 1212 if { [set i [lsearch -exact $u $x]] != -1 } { 1213 set u [lreplace $u $i $i] 1214 } 1215 } 1216 return $u 1217} 1218 1219#### cursor 1220 1221proc SetCursor {ws c} { 1222 # set cursor on each window in list $ws, all its toplevel children and 1223 # on the map window to $c 1224 # save previous cursors 1225 global Map Cursor CursorsChanged CMDLINE 1226 1227 if { $CMDLINE } { return } 1228 if { $CursorsChanged } { 1229 incr CursorsChanged 1230 return 1231 } 1232 set ws [linsert $ws 0 $Map] 1233 foreach w $ws { 1234 if { [winfo exists $w] } { 1235 set Cursor($w) [$w cget -cursor] 1236 $w configure -cursor $c 1237 foreach sub [winfo children $w] { 1238 if { [winfo toplevel $sub] == $sub } { 1239 set Cursor($sub) [$sub cget -cursor] 1240 $sub configure -cursor $c 1241 } 1242 } 1243 } 1244 } 1245 set CursorsChanged 1 1246 update idletasks 1247 return 1248} 1249 1250proc ResetCursor {ws} { 1251 # restore cursor on windows, all their toplevel children and on the 1252 # map window to saved one 1253 # $ws is list of windows 1254 global Map Cursor CursorsChanged CMDLINE 1255 1256 if { $CMDLINE } { return } 1257 incr CursorsChanged -1 1258 if { $CursorsChanged } { return } 1259 set ws [linsert $ws 0 $Map] 1260 foreach w $ws { 1261 $w configure -cursor $Cursor($w) 1262 foreach sub [winfo children $w] { 1263 if { [winfo toplevel $sub] == $sub } { 1264 if { ! [catch {set Cursor($sub)}] } { 1265 $sub configure -cursor $Cursor($sub) 1266 unset Cursor($sub) 1267 } 1268 } 1269 } 1270 unset Cursor($w) 1271 } 1272 update idletasks 1273 return 1274} 1275 1276### ISO characters; mainly from procs written by Luis Damas 1277 1278proc TextBindings {w} { 1279 # set text bindings according to user options 1280 global DELETE ISOLATIN1 1281 1282 if { $ISOLATIN1 && [info commands ISOBindings] != "" } { 1283 # the following proc is defined in file isolatin1.tcl 1284 # only consulted if $ISOLATIN1 was set at the beginning 1285 ISOBindings $w 1286 } 1287 if { $DELETE } { 1288 bind $w <Key-Delete> "DelCh[winfo class $w] $w ; break" 1289 } 1290 return 1291} 1292 1293proc DelChEntry {w} { 1294 # delete character before insertion point on entry 1295 1296 $w delete [expr [$w index insert]-1] 1297 return 1298} 1299 1300proc DelChText {w} { 1301 # delete character before insertion point on text window 1302 1303 $w delete "[$w index insert] -1 chars" 1304 return 1305} 1306 1307### quoting 1308 1309proc QuoteString {string} { 1310 # return string under quotes if it has spaces, escaping any quotes in it 1311 1312 if { [regexp { } $string] } { 1313 regsub -all {\"} $string "\\\"" string 1314 return \"$string\" 1315 } 1316 return $string 1317} 1318 1319proc WriteQuoteList {file list} { 1320 # write each element in list under quotes and escape quotes in it if any 1321 # do not insert newline at end 1322 1323 set n 0 1324 foreach x $list { 1325 if { $n != 0 } { puts -nonewline $file " " } 1326 puts -nonewline $file [QuoteString $x] 1327 set n 1 1328 } 1329 return 1330} 1331 1332proc WriteQuote {file string} { 1333 # write under quotes $string and escape quotes in it if any 1334 # do not insert newline at end 1335 1336 puts -nonewline $file [QuoteString $string] 1337 return 1338} 1339 1340### colours 1341 1342proc ColourToDec {c} { 1343 # convert name to RGB values 1344 global RGBNamed 1345 1346 set c [string trim $c " "] 1347 if { [string first # $c] == 0 } { 1348 set c [string tolower $c] 1349 if {! [regexp \ 1350 {^#([0-9a-f][0-9a-f])([0-9a-f][0-9a-f])([0-9a-f][0-9a-f])$} \ 1351 $c x h2 h1 h0] } { return -1 } 1352 scan $h2 "%x" b2 ; scan $h1 "%x" b1 ; scan $h0 "%x" b0 1353 return [list $b2 $b1 $b0] 1354 } 1355 if { [array names RGBNamed $c] == "" } { return -1 } 1356 return $RGBNamed($c) 1357} 1358 1359proc DecToColour {c2 c1 c0} { 1360 # convert RGB in decimal-triplet to hexadecimal representation 1361 1362 return [format "#%06x" [expr 65536*$c2+256*$c1+$c0]] 1363} 1364 1365proc ColourMatch {r g b ncs} { 1366 # find best-match colour for $r,$g,$b in set described by $ncs 1367 # $ncs is a list with for each colour an identifier/code followed by 1368 # RGB coordinates 1369 # return identifier/code of best-match 1370 # algorithm: in RGB space find minimum distance (compare vector 1371 # differences) 1372 1373 if { [llength $ncs]%4 != 0 } { BUG Bad matching colour set } 1374 set min 1000 1375 foreach "name x y z" $ncs { 1376 set x [expr $r-$x] ; set y [expr $g-$y] ; set z [expr $b-$z] 1377 if { $min > [set d [expr sqrt($x*$x+$y*$y+$z*$z)]] } { 1378 set match $name ; set min $d 1379 } 1380 } 1381 return $match 1382} 1383 1384##### posting to a web service 1385 1386proc WebPost {service login url fieldname message maxlength} { 1387 # edit and post a message to a web site 1388 # $service is the service name used when asking for login information 1389 # $login is set if authorization required 1390 # $maxlength == -1 when message can be of any length 1391 # use TclCurl 1392 # return 0 on failure 1393 global GMResConf MESS TXT COLOUR DPOSX DPOSY 1394 1395 if { [catch {package require TclCurl}] } { return 0 } 1396 set w .webpost 1397 set gs [grab current] 1398 GMToplevel $w message +$DPOSX+$DPOSY {} . \ 1399 {WM_DELETE_WINDOW {set GMResConf 0}} 1400 1401 frame $w.fr -borderwidth 5 -bg $COLOUR(confbg) 1402 label $w.fr.tit -text $TXT(message) 1403 frame $w.fr.ft 1404 set txt $w.fr.ft.txt 1405 text $txt -wrap word -width 70 -height 10 \ 1406 -exportselection true -yscrollcommand [list $w.fr.ft.sv set] 1407 $txt insert 1.0 $message 1408 if { $maxlength != -1 } { 1409 bind $txt <KeyRelease> [list TextCheckLimit $txt $maxlength bg messbg] 1410 } 1411 TextBindings $txt 1412 scrollbar $w.fr.ft.sv -command [list $txt yview] 1413 1414 frame $w.fr.bs 1415 button $w.fr.bs.ok -text $TXT(ok) -command { set GMResConf 1 } 1416 button $w.fr.bs.cancel -text $TXT(cancel) -command { set GMResConf 0 } 1417 1418 grid $txt -row 0 -column 0 -sticky nesw 1419 grid $w.fr.ft.sv -row 0 -column 1 -sticky ns 1420 pack $w.fr.bs.ok $w.fr.bs.cancel -side left -pady 5 1421 pack $w.fr.tit $w.fr.ft $w.fr.bs -side top -pady 5 1422 pack $w.fr 1423 update idletasks 1424 set gs [grab current] 1425 grab $w 1426 RaiseWindow $w 1427 tkwait variable GMResConf 1428 set message [$txt get 1.0 end] 1429 DestroyRGrabs $w $gs 1430 update idletasks 1431 if { $GMResConf } { 1432 if { $maxlength != -1 && [string length $message] > $maxlength } { 1433 set message [string replace $message $maxlength end] 1434 } 1435 set cmd [list configure -verbose 0 -url $url -connecttimeout 2 \ 1436 -post 1 -postfields "$fieldname=$message"] 1437 if { $login } { 1438 if { [set usrpwd [GMLogin $service]] == {} } { return 0 } 1439 set usrpwd "[lindex $usrpwd 0]:[lindex $usrpwd 1]" 1440 lappend cmd -userpwd $usrpwd 1441 } 1442 if { [catch {set chandle [curl::init]}] } { return 0 } 1443 set cmd [linsert $cmd 0 $chandle] 1444 if { [catch {eval $cmd}] || \ 1445 [catch {set res [$chandle perform]}] || \ 1446 [catch {$chandle reset}] } { 1447 return 0 1448 } 1449 return 1 1450 } 1451 return 0 1452} 1453 1454 1455