gpsman 6.4.4.2-2 / usr / lib / gpsman / util.tcl

#
# This file is part of:
#
#  gpsman --- GPS Manager: a manager for GPS receiver data
#
# Copyright (c) 1998-2013 Miguel Filgueiras migfilg@t-online.de
#
#    This program is free software; you can redistribute it and/or modify
#      it under the terms of the GNU General Public License as published by
#      the Free Software Foundation; either version 3 of the License, or
#      (at your option) any later version.
#
#      This program is distributed in the hope that it will be useful,
#      but WITHOUT ANY WARRANTY; without even the implied warranty of
#      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#      GNU General Public License for more details.
#
#      You should have received a copy of the GNU General Public License
#      along with this program.
#
#  File: util.tcl
#  Last change:  6 October 2013
#
# Includes contributions by Brian Baulch (baulchb _AT_ onthenet.com.au)
#  marked "BSB contribution"
#

## operations on menus

proc FillMenu {menu commdargs descr} {
    # entry point for recursive call of FillMenuRec
    #  $menu is the parent menu to fill in
    #  $commdargs is the callback and initial arguments to associate to
    #    each terminal entry; this is treated as a list to which will be
    #    appended the entry and $menu (even on sub-menus)
    #  $descr is a list describing the menu contents as follows:
    #    @ LIST  create sub-menu whose label is the head of $LIST, and
    #             whose description is the 2nd and following elements of $LIST
    #    ---     insert separator
    #    ENTRY   create menu entry
    # sub-menus will be created when menu length would exceed MAXMENUITEMS

    $menu delete 0 end
    FillMenuRec $menu $menu $commdargs $descr
    return
}

proc FillMenuRec {w menu commdargs descr} {
    # fill in menus recursively according to description
    # see proc FillMenu for the meaning of the arguments
    global MAXMENUITEMS TXT

    set notsub 1 ; set c 1 ; set dl [llength $descr]
    foreach item $descr {
	if { $c == $MAXMENUITEMS && $c != $dl } {
	    $menu add cascade -label "$TXT(more) ..." -menu $menu.m$c
	    set menu $menu.m$c ; destroy $menu ; menu $menu -tearoff 0
	    set c 1 ; set dl [expr $dl-$MAXMENUITEMS+1]
	}
	if { $notsub } {
	    if { $item != "@" } {
		if { $item != "---" } {
		    set cmd $commdargs
		    lappend cmd $item $w
		    $menu add command -label $item -command $cmd
		} else {
		    $menu add separator
		}
	    } else {
		set notsub 0 ; incr c -1 ; incr dl -1
	    }
	} else {
	    set notsub 1
	    set msub $menu.m$c
	    $menu add cascade -label [lindex $item 0] -menu $msub
	    destroy $msub ; menu $msub -tearoff 0
	    FillMenuRec $w $msub $commdargs [lrange $item 1 end]
	}
	incr c
    }
    return
}

proc FillMenuExec {menu call args} {
    # fill in menu with elements of list obtained by executing a command
    #  $call is list to which is appended the selected element and which
    #   will be called when a selection is made
    #  $args will be "eval"-uated to obtain the list
    # text for each element is the element
    global MAXMENUITEMS TXT

    if { [winfo exists $menu] } {
	$menu delete 0 end
    }
    set n 0 ; set m 0
    foreach f [eval $args] {
	if { $n > $MAXMENUITEMS } {
	    $menu add cascade -label "$TXT(more) ..." -menu $menu.m$m
	    set menu $menu.m$m
	    destroy $menu ; menu $menu -tearoff 0
	    set n 0 ; incr m
	}
	$menu add command -label $f -command [linsert $call end $f]
	incr n
    }
    return
}

proc FillPFormtMenu {menu comm args} {
    # fill in menu with possible position formats
    #  $comm is command to call with selected format followed by each of
    #    $args except the first one
    #  $args is a list whose first element is a list of formats not
    #    to be shown; the other elements are arguments to $comm
    global GRIDS TXT MAXMENUITEMS NONGRIDFMTS

    if { [winfo exists $menu] } {
	$menu delete 0 end
    }
    set n 0 ; set m 0
    # $GRIDS may change dynamically
    set fmts [concat $NONGRIDFMTS $GRIDS]
    foreach f [lindex $args 0] {
	if { [set i [lsearch -exact $fmts $f]] != -1 } {
	    set fmts [lreplace $fmts $i $i]
	}
    }
    foreach f $fmts {
	if { $n > $MAXMENUITEMS } {
	    $menu add cascade -label "$TXT(more) ..." -menu $menu.m$m
	    set menu $menu.m$m
	    destroy $menu ; menu $menu -tearoff 0
	    set n 0 ; incr m
	}
	$menu add command -label $TXT($f) \
	    -command [concat [list $comm $f] [lreplace $args 0 0]]
	incr n
    }
    return
}

### positions

proc FillPos {w pformt posns state chgvorp} {
    # create widgets to display positions
    #  $w is path to either an empty frame where a single position in
    #     lists $posns is to be displayed, or to frame that will contain
    #     frames with widgets for each position in $posns
    #  $pformt is the position format (see array POSTYPE, projections.tcl)
    #  $posns is a list of positions (see proc FormatPosition, compute.tcl)
    #  $state in {normal, disabled}
    #  $chgvorp is either "nil" or:
    #     - if there is a single position, the name of global variable to
    #     set to 1 if the user types in any entry and that contains the
    #     current position otherwise; see procs ChangePFormt and
    #     PosnGetCheckEmpty
    #     - else, "=PREFIX" describing global variables used in the same
    #     way for each position; each name has the prefix followed by the
    #     number from 1 of the position
    # the widgets for each position are created under frames $w.frp$i where $i
    #  is the order from 1
    # the frames $w.frp1, $w.frp2, ... are created and packed from top if
    #  they do not exist
    global TXT POSTYPE

    switch $POSTYPE($pformt) {
	latlong {
	    set ns [list $TXT(lat) $TXT(long)]
	    set fs "lat long" ; set ws "12 12"
	}
	utm {
	    set ns [list $TXT(ze) $TXT(zn) $TXT(eastng) $TXT(nrthng)]
	    set fs "ze zn eng nng" ; set ws "3 3 8 8"
	}
	grid {
	    set ns [list $TXT(zone) $TXT(eastng) $TXT(nrthng)]
	    set fs "zn eng nng" ; set ws "5 8 8"
	}
	nzgrid {
	    set ns [list $TXT(eastng) $TXT(nrthng)]
	    set fs "eng nng" ; set ws "8 8"
	}
	mh {
	    set ns "" ; set fs  mh ; set ws 8
	}
    }
    if { [winfo children $w] == "" } {
	# single position, repopulate $w
	FillEntries $w $fs $ns $ws [lrange [lindex $posns 0] 2 end] $state \
	    $chgvorp
	return
    }
    set n 1
    if { [regsub {^=} $chgvorp "" prefix] } {
	set nvar 1
    } else { set nvar 0 ; set chgvar $chgvorp }
    foreach posn $posns {
	set wf $w.frp$n
	if { ! [winfo exists $wf] } {
	    frame $wf
	    pack $wf -side top
	}	    
	set ep [lrange $posn 2 end]
	if { $nvar } { set chgvar ${prefix}$n }
	FillEntries $wf $fs $ns $ws $ep $state $chgvar
	incr n
    }
    return
}

proc PosnGetCheck {w datum errproc chgvar} {
    # get and check position in edit/show window
    #  $w is path to parent window of position widgets, whose parent
    #     contains the widget for the position format
    #  $errproc is procedure to call on error
    #  $chgvar is either "nil" or name of global variable to set to
    #     1 if the user types in any entry and that contains the
    #     current position otherwise
    # returns "nil" on error or if there are empty fields
    global MESS

    if { [set r [PosnGetCheckEmpty $w $datum $errproc $chgvar]] == \
	    "empty" } {
	$errproc $MESS(emptypos)
	return nil
    }
    return $r
}

proc PosnGetCheckEmpty {w datum errproc chgvar} {
    # get and check position in edit/show window
    #  $w is path to parent window of position widgets, whose parent
    #     contains the widget for the position format
    #  $errproc is procedure to call on error
    #  $chgvar is either "nil" or name of global variable to set to
    #     1 if the user types in any entry and that contains
    #     the current position otherwise (possibly "")
    # returns "empty" if there are empty fields, and "nil" on error
    global MESS INVTXT POSTYPE

    if { $chgvar != "nil" } {
	global $chgvar

	if { [set p [set $chgvar]] == "" } { return empty }
	if { $p != 1 } { return $p }
    }
    set wp [winfo parent $w]
    set pf $INVTXT([$wp.pfmt cget -text])
    switch [set ptype $POSTYPE($pf)] {
	latlong {
	    set wlat [$w.lat get] ; set wlong [$w.long get]
	    if { $wlat == "" && $wlong == "" } { return empty }
	    if { [CheckLat $errproc $wlat $pf] && \
		    [CheckLong $errproc $wlong $pf] } {
		set latdeg [Coord $pf $wlat S]
		set longdeg [Coord $pf $wlong W]
		set p [list $latdeg $longdeg $wlat $wlong]
	    } else { return nil }
	}
	utm {
	    foreach m "ze zn eng nng" c "ZE ZN Number Number" {
		set $m [$w.$m get]
		if { [set $m] == "" } {
		    return empty
		} elseif { ! [Check$c $errproc [set $m]] } { return nil }
	    }
	    if { $eng != 0 } { set eng [string trimleft $eng "0"] }
	    if { $nng != 0 } { set nng [string trimleft $nng "0"] }
	    set pd [UTMToDegrees $ze $zn $eng $nng $datum]
	    set p [list [lindex $pd 0] [lindex $pd 1] $ze $zn $eng $nng]
	}
	grid -
	nzgrid {
	    foreach m "eng nng" {
		set $m [$w.$m get]
		if { [set $m] == "" } {
		    return empty
		} elseif { ! [CheckFloat $errproc [set $m]] } { return nil }
	    }
	    if { $eng != 0 } { set eng [string trimleft $eng "0"] }
	    if { $nng != 0 } { set nng [string trimleft $nng "0"] }
	    if { $ptype == "grid" } {
		set gr 1
		set zn [$w.zn get]
		if { ! [CheckZone $errproc $zn $pf] } {
		    if { $zn == "" } { return empty }
		    return nil
		}
	    } else { set gr 0 ; set zn "" }
	    if { [BadDatumFor $pf $datum GMMessage] != 0 } { return nil }
	    set p [GridToDegrees $pf $zn $eng $nng $datum]
	    if { $p == 0 } {
		$errproc $MESS(outofgrid)
		return nil
	    }
	    if { $gr } {
		lappend p $zn $eng $nng
	    } else { lappend p $eng $nng }
	}
	mh {
	    set mh [string trim [$w.mh get] " "]
	    if { $mh == "" } { return empty }
	    if { ! [CheckMHLocator $errproc $mh] } { return nil }
	    set p [linsert [MHLocToDegrees $mh] end $mh]
	}
    }
    if { $chgvar != "nil" } {
	global $chgvar

	set $chgvar $p
    }
    return $p
}

proc RevertPos {w pformt ptype posn} {
    # change position values keeping its format
    #  $w is path to parent window of position widgets, whose parent
    #     contains the widget for the position format
    #  $pformt is position format (see projections.tcl)
    #  $ptype is type of position format (see array POSTYPE, projections.tcl)
    #  $posn is the position (see proc FormatPosition, compute.tcl)
    global TXT

    [winfo parent $w].pfmt configure -text $TXT($pformt)
    switch $ptype {
	latlong {
	    set bs {lat long} ; set is {2 3}
	}
	utm {
	    set bs {ze zn eng nng} ; set is {2 3 4 5}
	}
	grid {
	    set bs {zn eng nng} ; set is {2 3 4}
	}
	nzgrid {
	    set bs {eng nng} ; set is {2 3}
	}
	mh {
	    set bs mh ; set is 2
	}
    }
    set st [$w.[lindex $bs 0] cget -state]
    foreach b $bs k $is {
	$w.$b configure -state normal
	$w.$b delete 0 end
	$w.$b insert 0 [lindex $posn $k]
	$w.$b configure -state $st
    }
    return
}

proc RedrawPos {w pformt posn chgvar st} {
    # display position under a new format
    #  $w is path to parent window of position widgets, whose parent
    #     contains the widget for the position format
    #  $pformt is the new format (see projections.tcl)
    #  $posn is the position (see proc FormatPosition, compute.tcl)
    #  $chgvar is either "nil" or name of global variable to set to
    #     1 if the user types in any entry and that contains the
    #     current position otherwise (possibly "")
    #  $st is state for position widgets
    global TXT

    foreach s [winfo children $w] { destroy $s }
    FillPos $w $pformt [list $posn] $st $chgvar
    return
}

proc ChangePFormt {pformt dvar dvref w chgvorp st} {
    # change format of positions in window
    #  $w is path to parent window containing frp$i sub-frames for
    #     each position with $i an integer from 1
    #  $pformt is position format (see array POSTYPE, projections.tcl)
    #  $chgvorp is either "nil" or:
    #     - if there is a single position, the name of global variable to
    #     set to 1 if the user types in any entry and that contains the
    #     current position otherwise; see procs ChangePFormt and
    #     PosnGetCheckEmpty
    #     - else, "=PREFIX" describing global variables used in the same
    #     way for each position; each name has the prefix followed by the
    #     number from 1 of the position
    #  $dvar is name of global variable or array for datum
    #  $dvref is name of variable or array(element) for datum
    #  $st is state of the position widgets
    global INVTXT $dvar MESS POSTYPE TXT

    set opf $INVTXT([$w.pfmt cget -text])
    if { $opf == $pformt } { return }
    set datum [set $dvref]
    if { [set ndatum [BadDatumFor $pformt $datum Ignore]] == 0 } {
	set ndatum $datum
    }
    if { [regsub {^=} $chgvorp "" prefix] } {
	set nvar 1
    } else { set nvar 0 ; set chgvar $chgvorp }
    set frs "" ; set posns ""
    foreach fr [winfo children $w] {
	if { [regexp {\.frp([0-9]+)$} $fr x n] } {
	    lappend frs $fr
	    if { $nvar } { set chgvar ${prefix}$n }
	    set p [PosnGetCheckEmpty $fr $datum GMMessage $chgvar]
	    if { $p == "nil" } { return }
	    if { $p == "empty" } {
		set p ""
	    } else {
		set p [lindex \
			   [FormatPosition [lindex $p 0] [lindex $p 1] $datum \
				$pformt ""] 0]
		if { [lindex $p 2] == "--" } {
		    GMMessage $MESS(outofgrid)
		    return
		}
	    }
	    lappend posns $p
	}
    }
    set ot $POSTYPE($opf) ; set nt $POSTYPE($pformt)
    foreach fr $frs np $posns {
	if { $chgvorp != "nil" } {
	    if { $nvar } { set chgvar ${prefix}$n }
	    global $chgvar

	    set $chgvar $np
	}
	if { $ot == $nt } {
	    RevertPos $fr $pformt $nt $np
	} else {
	    RedrawPos $fr $pformt $np $chgvar $st
	}
    }
    set $dvref $ndatum
    $w.pfmt configure -text $TXT($pformt)
    return
}

proc ChangeDatum {datum dvar dvref chgvorp posfr st} {
    # change datum
    #   $posfr is path to parent window containing frp$i sub-frames for
    #     each position with $i an integer from 1
    # see proc ChangePFormt for the meaning of the other arguments
    global $dvar INVTXT MESS POSTYPE

    set olddatum [set $dvref]
    if { $olddatum == $datum } { return }
    set pformt $INVTXT([$posfr.pfmt cget -text])
    if { [BadDatumFor $pformt $datum GMMessage] != 0 } {
	return
    }
    if { [regsub {^=} $chgvorp "" prefix] } {
	set nvar 1
    } else { set nvar 0 ; set chgvar $chgvorp }
    foreach fr [winfo children $posfr] {
	if { [regexp {\.frp([0-9]+)$} $fr x n] } {
	    if { $nvar } { set chgvar ${prefix}$n }
	    set op [PosnGetCheck $fr $olddatum Ignore $chgvar]
	    if { $op != "nil" } {
		set np [lindex [FormatPosition [lindex $op 0] [lindex $op 1] \
				    $olddatum $pformt $datum] 0]
		RevertPos $fr $pformt $POSTYPE($pformt) $np
		if { $chgvar != "nil" } {
		    global $chgvar

		    set $chgvar $np
		}
	    }
	}
    }
    set $dvref $datum
    return
}

## directory listing

proc FillDir {w} {
    # fill in listbox $w with files in a directory
    # insert "../" at the beginning, followed by sub-directories
    #  and then ordinary files

    set dl "" ; set fl ""
    foreach f [lsort [glob -nocomplain *]] {
	if { [file isdirectory $f] } {
	    set dl [linsert $dl 0 $f]
	} else {
	    set fl [linsert $fl 0 $f]
	}
    }
    foreach f $fl { $w insert 0 $f }
    foreach d $dl { $w insert 0 "$d/" }
    $w insert 0 "../"
    return
}

## operations on windows

proc CloseWindows {ws} {
    # close windows using their specific WM_DELETE_WINDOW command if any

    foreach w $ws {
	if { [winfo exists $w] } {
	    if { [set c [wm protocol $w WM_DELETE_WINDOW]] != "" } {
		catch {eval $c}
	    } else { destroy $w }
	}
    }
    return
}

proc DestroyRGrabs {w oldgrabs} {
    # destroy window $w and restore previous grabs

    destroy $w
    foreach w $oldgrabs {
	if { [winfo exists $w] } { grab $w }
    }
    return
}

proc Raise {w} {

    raise $w ; focus $w
    return
}

proc RaiseWindow {w} {
    # keep a window on top
    # CANNOT BE USED for windows that create menus: they will disappear!
    global WindowStack

    if { [winfo exists $w] } {
	raise $w
	if { $WindowStack == "" } { after 2000 RaiseWindowStack }
	set WindowStack [linsert $WindowStack 0 $w]
	update idletasks
    }
    return
}

proc RaiseWindowStack {} {
    # keep a window on top if it is on top of the stack
    global WindowStack

    while { $WindowStack != "" } {
	if { [winfo exists [set w [lindex $WindowStack 0]]] } {
	    raise $w
	    after 2000 RaiseWindowStack
	    update idletasks
	    break
	} else {
	    set WindowStack [lreplace $WindowStack 0 0]
	}
    }
    return
}

proc ToggleWindow {w x y} {
    # from normal to iconic and back (with geometry +$x+$y)
    # in fact, because some window managers do not iconify windows
    #  just put them at large
    # in fact, because some window managers do not even deal correctly
    #  with putting windows at large, just raise them...
    # ... and try to de-iconify them if they are icons
    global MESS

    if { [winfo exists $w] } {
	if { [wm state $w] == "iconic" } {
  	    wm deiconify $w ; wm geometry $w +$x+$y
  	}
	raise $w
    } else {
	GMMessage $MESS(windowdestr)
    }
#      switch [wm state $w] {
#  	normal {
#  	    # wm iconify $w
#  	    set g [winfo geometry $w]
#  	    if { [regexp {[0-9]+x[0-9]+\+(-?[0-9]+)\+-?[0-9]+} $g z cx] } {
#  		if { $cx < 0 } {
#  		    wm geometry $w +$x+$y
#  		    raise $w ; focus $w
#  		} else {
#  		    wm geometry $w +-10000+-10000
#  		}
#  	    } else {
#  		GMMessage "Bad result from winfo geometry $w: $g"
#  	    }
#  	}
#  	iconic {
#  	    wm deiconify $w ; wm geometry $w +$x+$y
#  	}
#  	withdrawn { bell }
#      }
    return
}

## changing state of interface

proc ChangeOnState {what st} {
    # change state of some widgets according to specification in WConf array
    #  $what is index in WConf array
    #  $st in {normal, disabled}
    # entries of WConf used here are lists of lists; information in each
    #  sublist depends on its 1st element: 
    #   menu - 2nd element is a list of pairs with menu path and list of
    #          entries
    #   button (or menubutton) - 2nd element is list of paths
    global WConf CMDLINE

    if { $CMDLINE } { return }
    foreach p $WConf($what) {
	switch [lindex $p 0] {
	    menu {
		foreach m [lindex $p 1] {
		    set w [lindex $m 0]
		    foreach e [lindex $m 1] {
			$w entryconfigure $e -state $st
		    }
		}
	    }
	    button -  menubutton {
		foreach b [lindex $p 1] {
		    $b configure -state $st
		}
	    }
	}
    }
    return
}

## operations on entries

proc CheckEntries {errproc errval descr} {
    # check values given on entries
    #  $errproc proc to be called on error
    #  $descr is a list of pairs or triplets with:
    #     - path to the entry
    #     - procedure to be called for checking the data,
    #        with the following arguments:
    #          - $errproc
    #          - the contents of the entry
    #          - the argument to checking procedure if it exists
    #     - argument to checking procedure (optional)
    # return list with contents of entries, or $errval on error

    set r ""
    foreach item $descr {
	set w [lindex $item 0] ; set p [lindex $item 1]
	set a [lrange $item 2 end]
	set info [$w get]
	if { $a != "" } {
	    set ok [$p $errproc $info $a]
	} else { set ok [$p $errproc $info] }
	if { $ok } {
	    lappend r $info
	} else {
	    focus $w
	    return $errval
	}
    }
    return $r
}

proc FillEntries {w names titles widths vals state chgvar} {
    # create and fill a set of entries under window $w
    #  $names is a list of names for the widgets
    #  $titles is associated list of titles to show as labels
    #  $widths is associated list of widths
    #  $vals is associated list of initial values
    #  $state in {normal, disabled}
    #  $chgvar is either "" or name of global variable to set to
    #     1 if the user types or pastes in any entry

    foreach n $names t $titles l $widths v $vals {
	if { $n == "" } { return }
	label $w.${n}title -text "$t:"
	entry $w.$n -width $l -exportselection 1
	$w.$n insert 0 $v
	TextBindings $w.$n
	if { $state == "normal" && $chgvar != "" } {
	    bind $w.$n <Any-Key> "set $chgvar 1"
	    bind $w.$n <Any-ButtonRelease> "set $chgvar 1"
	}
	$w.$n configure -state $state
	pack $w.${n}title $w.$n -side left -padx 3
    }
    return
}

proc ShowTEdit {entry string flag} {
    # show a string on an entry
    # enable edition and set text bindings according to $flag

    $entry configure -state normal
    $entry delete 0 end ; $entry insert 0 $string
    if { $flag } {
	TextBindings $entry
    } else {
	$entry configure -state disabled
    }
    return
}

## operations on text

proc TextCheckLimit {txt max bgix errbgix} {
    # change the background of text characters that are beyond the
    #  given number of characters
    #  $bgix is the normal background index in COLOUR array
    #  $errbgix is the error background index in COLOUR array
    # a tag "ob" is used for this
    global COLOUR

    $txt tag delete ob
    set max "1.0+$max chars"
    if { [$txt compare end > $max] } {
	$txt tag add ob $max end
	$txt tag configure ob -background $COLOUR($errbgix)
    } else { $txt configure -background $COLOUR($bgix) }
    return
}

## operations on data

proc CompareVals {arr i j} {
    # compare as strings two array elements
    global $arr

    return [string compare "[set [set arr]($i)]" "[set [set arr]($j)]"]
}

proc MergeData {list ps vs} {
    # put the values $vs into $list in positions $ps
    # empty elements will be created if positions extend the list

    set l [llength $list]
    foreach p $ps v $vs {
	while { $p >= $l } {
	    lappend list ""
	    incr l
	}
	set list [lreplace $list $p $p $v]
    }
    return $list
}

proc MakeSplit {lls ixs} {
    # split a list of lists into lists of lists according to the given
    #  indices

    set rs ""
    set del 0
    while 1 {
	if { $ixs == "" } {
	    lappend rs $lls
	    break
	}
	set void 1
	set ixn [expr [lindex $ixs 0]-$del] ; set ixs [lreplace $ixs 0 0]
	incr del $ixn
	set sl "" ; set rsl ""
	foreach l $lls {
	    lappend sl [lrange $l 0 [expr $ixn-1]]
	    if { [set sll [lrange $l $ixn end]] != "" } { set void 0 }
	    lappend rsl $sll
	}
	lappend rs $sl
	if { $void } { break }
	set lls $rsl
    }
    return $rs
}

proc Delete {l x} {
    # return list obtained from $l by deleting $x

    if { [set ix [lsearch -exact $l $x]] != -1 } {
	return [lreplace $l $ix $ix]
    }
    return $l
}

proc Subtract {l1 l2} {
    # return list obtained from $l1 by deleting all elements in $l2

    foreach x $l2 {
	if { [set ix [lsearch -exact $l1 $x]] != -1 } {
	    set l1 [lreplace $l1 $ix $ix]
	}
    }
    return $l1
}

proc Intersect1 {l1 l2} {
    # return first common element in both lists or empty list if none

    foreach e $l1 {
	if { [lsearch -exact $l2 $e] != -1 } { return $e }
    }
    return ""
}

proc ListReplace {l olds news} {
    # replace in list $l any ocurrences of elements of list $olds
    #  by the aligned elements of list $news
    # $l may have repeated elements
    # return pair with flag set if there were replacements and resulting
    #  list

    set chg 0
    foreach o $olds n $news {
	foreach i [lsearch -exact -all $l $o] {
	    set l [lreplace $l $i $i $n]
	    incr chg
	}
    }
    return [list $chg $l]
}

proc FindArrayIndices {array val errix} {
    # check that $val is an element of $array (possibly with repeated values)
    # return indices of $val on success and $errix on error
    global $array

    set l "" ; set n 0
    foreach an [array names $array] {
	if { [set [set array]($an)] == $val } {
	    lappend l $an ; set n 1
	}
    }
    if { $n } { return $l }
    return $errix
}

proc AssignGlobal {var val} {
    # assign $val to global $var
    global $var

    set $var $val
    return
}

## hiding and showing columns of objects in a grid

proc CollapseColumn {objs col label type args} {
    # collapse column $col of objects $objs in a frame managed as grid
    #  and create an object to restore it
    #  $objs must be list of all objects ordered by row (from 0)
    #  $label is title for the new object
    #  $type describes what is the new object and $args:
    #    ==button, $args=="$fr $orient" where
    #             $fr is frame (managed as grid) parent of new button
    #             $orient in {row, col} is how the buttons are shown in $fr
    #             - a label $fr.title is assumed to be the first element of
    #             the row/column
    #    ==menubtentry, $args=="$menu $menubutton"
    #             $menubutton must enabled if it is disabled

    foreach o $objs { grid forget $o }
    switch $type {
	button {
	    set fr [lindex $args 0]
	    set sls [grid slaves $fr]
	    if { [set n [llength $sls]] == 0 } {
		grid configure $fr.title -row 0 -column 0 -sticky news
		set n 1
	    }
	    set b $fr.b$col
	    if { [winfo exists $b] } {
		if { [lsearch -exact $sls $b] != -1 } { return }
	    } else {
		button $b -text $label -command \
			[list ShowColumn $objs $col $type $fr $b]
	    }
	    if { [lindex $args 1] == "col" } {
		set r $n ; set c 0
	    } else { set r 0 ; set c $n }
	    grid configure $b -row $r -column $c -sticky news
	}
	menubtentry {
	    set menu [lindex $args 0] ; set menubutton [lindex $args 1]
	    if { [$menubutton cget -state] == "disabled" } {
		$menubutton configure -state normal
	    }
	    $menu add command -label $label -command \
		    [list ShowColumn $objs $col $type $menu $menubutton $label]
	}
    }
    return
}

proc ShowColumn {objs col type args} {
    # show column $col of objects $objs in a frame managed as grid and
    #  hide/delete object that invoked this command
    #  $objs, $type as in proc CollapseColumn
    #  $type==button, $args=="$fr $button"
    #       if frame has a single slave (assumed to be $fr.title) it is hidden
    #  $type==menubtentry, $args=="$menu $menubutton $label"
    #       if menu becomes empty, menubutton is disabled

    set r 0
    foreach o $objs {
	grid configure $o -row $r -column $col -sticky news
	incr r
    }
    switch $type {
	button {
	    grid forget [lindex $args 1]
	    set fr [lindex $args 0]
	    if { [grid slaves $fr] == $fr.title } {
		grid forget $fr.title
	    }
	}
	menubtentry {
	    set menu [lindex $args 0] ; set menubutton [lindex $args 1]
	    set label [lrange $args 2 end]
	    set n [$menu index last]
	    for { set ix 0 } { $ix <= $n } { incr ix } {
		if { [$menu entrycget $ix -label] == $label } {
		    $menu delete $ix
		    if { $ix+$n == 0 } {
			$menubutton configure -state disabled
		    }
		    break
		}
	    }	    
	}
    }
    return
}

## selecting in and scrolling listboxes

proc MultSelect {w ix bxs} {
    # select only one element at index $ix in each listbox in $bxs
    #  with $w the parent window
    foreach l $bxs {
	$w.$l selection clear 0 end
	$w.$l selection set $ix
    }
    return
}

proc MultExtSelect {bx bxs} {
    # adjust extended selection in each listbox in $bxs that are siblings
    #  of $bx

    set s [$bx curselection]
    set w [winfo parent $bx]
    foreach l $bxs {
	if { $l != $bx } {
	    $w.$l selection clear 0 end
	    foreach ix $s { $w.$l selection set $ix }
	}
    }
    return
}

proc ScrollListIndex {box char} {
    # scroll listbox so that first element with initial >= $char is shown
    # this is case sensitive!
    # if none found, scroll to end

    if { $char == "" } { return }
    set i 0
    foreach e [$box get 0 end] {
	if { [string compare $char [string range $e 0 0]] <= 0 } {
	    $box see $i
	    return
	}
	incr i
    }
    $box see end
    return
}

proc ScrollMany {boxs args} {

    foreach b $boxs {
	eval $b yview $args
    }
    return
}

# BSB contribution: support for wheelmouse scrolling of listboxes
proc Mscroll {boxes} {

    foreach b $boxes {
	bind $b <Button-5> " ScrollMany [list $boxes] scroll 5 units "
	bind $b <Button-4> " ScrollMany [list $boxes] scroll -5 units "
	bind $b <Shift-Button-5> " ScrollMany [list $boxes] scroll 1 units "
	bind $b <Shift-Button-4> " ScrollMany [list $boxes] scroll -1 units "
	bind $b <Control-Button-5> " ScrollMany [list $boxes] scroll 1 pages "
	bind $b <Control-Button-4> " ScrollMany [list $boxes] scroll -1 pages "
    }
    return
}

## balloon help (mostly adapted from macau, by the same author)

proc BalloonBindings {wci lst} {
    # set bindings for balloon help
    #  $wci either a window path or a list with canvas path and item or tag
    #  $lst is list of args needed for the call to proc BalloonCreate

    if { [llength $wci] == 1 } {
	bind $wci <Enter> [list Balloon $lst]
	bind $wci <Motion> { BalloonMotion %X %Y }
	bind $wci <Leave> BalloonDestroy
    } else {
	set cv [lindex $wci 0] ; set it [lindex $wci 1]
	$cv bind $it <Enter> [list Balloon $lst]
	$cv bind $it <Motion> { BalloonMotion %X %Y }
	$cv bind $it <Leave> BalloonDestroy
    }
    return
}

proc BalloonButton {path lst} {
    # create button with given $path to display a balloon help
    #  $lst is list of args needed for the call to proc BalloonCreate
    # return $path
    global SYMBOLIMAGE

    button $path -image $SYMBOLIMAGE(interr) \
	    -command "BalloonCreate 12000 $lst"
    bind $path <Motion> { BalloonMotion %X %Y }
    bind $path <Enter> BalloonDestroy    
    return $path
}

proc Balloon {lst} {
    global BalloonStart BalloonHelp

    if { $BalloonHelp } {
	set BalloonStart [after 2000 "BalloonCreate 10000 $lst"]
    }
    return
}

proc NewBalloon {blln mess geom} {

    global COLOUR

    destroy $blln
    toplevel $blln
    wm resizable $blln 0 0
    wm overrideredirect $blln 1
    wm geometry $blln $geom
    wm group $blln .
    label $blln.mess -text $mess -relief groove -bg $COLOUR(ballbg) \
	-fg $COLOUR(ballfg)
    pack $blln.mess
    return
}

proc BalloonCreate {timeout args} {
    #  $timeout is either 0 or msecs to destroy balloon help
    global BalloonX BalloonY BalloonEnd TXT COLOUR

    switch -glob -- [set a0 [lindex $args 0]] {
	=* {
	    set mess [string range $a0 1 end]
	}
	default {
	    if { [catch [list set mess $TXT($a0)]] } {
		set mess $TXT(nohelp)
	    }
	}
    }
    NewBalloon .balloon $mess +$BalloonX+$BalloonY
    if { $timeout } {
	set BalloonEnd [after $timeout "destroy .balloon"]
    } else { set BalloonEnd "" }
    return
}

proc BalloonMotion {x y} {
    global BalloonX BalloonY

    set BalloonX [expr $x+9] ; set BalloonY [expr $y+9]
    if { [winfo exists .balloon] } {
	wm geometry .balloon +$BalloonX+$BalloonY
    }
    return
}

proc BalloonDestroy {} {
    global BalloonStart BalloonEnd

    catch {after cancel $BalloonStart}
    catch {after cancel $BalloonEnd}
    destroy .balloon
    return
}

## double-click or qualified single-click vs. single-click bindings

# avoid compound clicks being taken as a single-click followed
#  by some other event

# usage in bindings, as in:
#  bind TAG <Button-1> { SafeSingleClick 1 MYCOMMAND1 ARG1 ... ARGn }
#  bind TAG <Double-1> { SafeCompoundClick 1 MYCOMMAND2 ARG1 ... ARGk }

array set SafeClick {
    delay,1 300    job,1 ""    time,1 1e77
    delay,2 300    job,2 ""    time,2 1e77
    delay,3 300    job,3 ""    time,3 1e77
}

proc SafeSingleClick {button comm args} {
    # delay effect of single-click so that it may be cancelled by
    #  a compound-click binding
    #  $button in {1, 2, 3}  (see initialization of SafeClick array)
    #  $comm is the command to be executed in answer to the single-click
    #  $args are the arguments to this command if any
    # the following global array is used
    #  $SafeClick(job,$button) has the job id to be cancelled
    #  $SafeClick(delay,$button) is the delay in ms
    #  $SafeClick(time,$button) is the time of last compound-click if any
    global SafeClick

    if { abs([clock clicks -milliseconds]-$SafeClick(time,$button)) < \
	    $SafeClick(delay,$button) } { return }
    set SafeClick(time,$button) 1e77
    set SafeClick(job,$button) \
	    [after $SafeClick(delay,$button) eval $comm $args]
    return
}

proc SafeCompoundClick {button comm args} {
    # cancel effect of single-click before executing command (normally
    #  as a result of a compound-click)
    #  $comm is the command to be executed in answer to the single-click
    #  $args are the arguments to this command if any
    # the same global var as in proc SafeSingleClick is used
    global SafeClick

    after cancel $SafeClick(job,$button)
    set SafeClick(time,$button) [clock clicks -milliseconds]
    eval $comm $args
    return
}

## canvas

proc TurnObject {trk data} {
    # turn canvas object $trk degrees from vertical north
    #  $data is list with coordinates of rotation centre (x_m, y_m),
    #    tag of object, canvas path and list of coordinates relative to
    #    (x_m, y_m)

    foreach "xm ym tag cv cs0" $data {}
    set rad [expr $trk*0.01745329251994329576]
    set cos [expr cos($rad)] ; set sin [expr sin($rad)]
    set cs ""
    foreach "x y" $cs0 {
	lappend cs [expr round($xm+$x*$cos+$y*$sin)] \
		   [expr round($ym-$x*$sin+$y*$cos)]
    }
    eval $cv coords $tag $cs
    update idletasks
    return
}

proc CanvasChangeFont {cv v vref} {
    # change font in canvas using proc GMSelectFont
    #  $v is name to declare as global
    #  $vref is reference to set (variable name or array and index)
    # all canvas items with tag txt will be reconfigured
    global $v TkDefaultFont

    if { [set f [GMSelectFont $TkDefaultFont]] == {} } { return } 
    set $vref $f
    foreach it [$cv find withtag txt] {
	$cv itemconfigure $it -font $f
    }
    return
}

## varia

proc Measure {text} {
    # length of a string plus 2

    return [expr 2+[string length $text]]
}

proc Apply {list f args} {
    # apply proc $f to each element of list
    # $f is called with arguments $args and list element

    set r ""
    foreach i $list {
	lappend r [$f $args $i]
    }
    return $r
}

proc Undefined {list} {
    # test whether there is a -1 in list

    foreach i $list {
	if { $i == -1 } { return 1 }
    }
    return 0
}

proc Complement {u l} {
    # compute the complement to list $u of list $l

    foreach x $l {
	if { [set i [lsearch -exact $u $x]] != -1 } {
	    set u [lreplace $u $i $i]
	}
    }
    return $u
}

#### cursor

proc SetCursor {ws c} {
    # set cursor on each window in list $ws, all its toplevel children and
    #  on the map window to $c
    # save previous cursors
    global Map Cursor CursorsChanged CMDLINE

    if { $CMDLINE } { return }
    if { $CursorsChanged } {
	incr CursorsChanged
	return
    }
    set ws [linsert $ws 0 $Map]
    foreach w $ws {
	if { [winfo exists $w] } {
	    set Cursor($w) [$w cget -cursor]
	    $w configure -cursor $c
	    foreach sub [winfo children $w] {
		if { [winfo toplevel $sub] == $sub } {
		    set Cursor($sub) [$sub cget -cursor]
		    $sub configure -cursor $c
		}
	    }
	}
    }
    set CursorsChanged 1
    update idletasks
    return
}

proc ResetCursor {ws} {
    # restore cursor on windows, all their toplevel children and on the
    #  map window to saved one
    #  $ws is list of windows
    global Map Cursor CursorsChanged CMDLINE

    if { $CMDLINE } { return }
    incr CursorsChanged -1
    if { $CursorsChanged } { return }
    set ws [linsert $ws 0 $Map]
    foreach w $ws {
	$w configure -cursor $Cursor($w)
	foreach sub [winfo children $w] {
	    if { [winfo toplevel $sub] == $sub } {
		if { ! [catch {set Cursor($sub)}] } {
		    $sub configure -cursor $Cursor($sub)
		    unset Cursor($sub)
		}
	    }
	}
	unset Cursor($w)
    }
    update idletasks
    return
}

### ISO characters; mainly from procs written by Luis Damas

proc TextBindings {w} {
    # set text bindings according to user options
    global DELETE ISOLATIN1

    if { $ISOLATIN1 && [info commands ISOBindings] != "" } {
	# the following proc is defined in file isolatin1.tcl
	#  only consulted if $ISOLATIN1 was set at the beginning
	ISOBindings $w
    }
    if { $DELETE } {
	bind $w <Key-Delete> "DelCh[winfo class $w] $w ; break"
    }
    return
}

proc DelChEntry {w} {
    # delete character before insertion point on entry

    $w delete [expr [$w index insert]-1]
    return
}

proc DelChText {w} {
    # delete character before insertion point on text window

    $w delete "[$w index insert] -1 chars"
    return
}

### quoting

proc QuoteString {string} {
    # return string under quotes if it has spaces, escaping any quotes in it

    if { [regexp { } $string] } {
	regsub -all {\"} $string "\\\"" string
	return \"$string\"
    }
    return $string
}

proc WriteQuoteList {file list} {
    # write each element in list under quotes and escape quotes in it if any
    # do not insert newline at end

    set n 0
    foreach x $list {
	if { $n != 0 } { puts -nonewline $file " " }
	puts -nonewline  $file [QuoteString $x]
	set n 1
    }
    return
}

proc WriteQuote {file string} {
    # write under quotes $string and escape quotes in it if any
    # do not insert newline at end

    puts -nonewline $file [QuoteString $string]
    return
}

### colours

proc ColourToDec {c} {
    # convert name to RGB values
    global RGBNamed

    set c [string trim $c " "]
    if { [string first # $c] == 0 } {
	set c [string tolower $c]
	if {! [regexp \
		{^#([0-9a-f][0-9a-f])([0-9a-f][0-9a-f])([0-9a-f][0-9a-f])$} \
		$c x h2 h1 h0] } { return -1 }
	scan $h2 "%x" b2 ; scan $h1 "%x" b1 ; scan $h0 "%x" b0
	return [list $b2 $b1 $b0]
    }
    if { [array names RGBNamed $c] == "" } { return -1 }
    return $RGBNamed($c)
}

proc DecToColour {c2 c1 c0} {
    # convert RGB in decimal-triplet to hexadecimal representation

    return [format "#%06x" [expr 65536*$c2+256*$c1+$c0]]
}

proc ColourMatch {r g b ncs} {
    # find best-match colour for $r,$g,$b in set described by $ncs
    #  $ncs is a list with for each colour an identifier/code followed by
    #     RGB coordinates
    # return identifier/code of best-match
    # algorithm: in RGB space find minimum distance (compare vector
    #  differences)

    if { [llength $ncs]%4 != 0 } { BUG Bad matching colour set }
    set min 1000
    foreach "name x y z" $ncs {
	set x [expr $r-$x] ; set y [expr $g-$y] ; set z [expr $b-$z]
	if { $min > [set d [expr sqrt($x*$x+$y*$y+$z*$z)]] } {
	    set match $name ; set min $d
	}
    }
    return $match
}

##### posting to a web service

proc WebPost {service login url fieldname message maxlength} {
    # edit and post a message to a web site
    #  $service is the service name used when asking for login information
    #  $login is set if authorization required
    #  $maxlength == -1  when message can be of any length
    # use TclCurl
    # return 0 on failure
    global GMResConf MESS TXT COLOUR DPOSX DPOSY

    if { [catch {package require TclCurl}] } { return 0 }
    set w .webpost
    set gs [grab current]
    GMToplevel $w message +$DPOSX+$DPOSY {} . \
	{WM_DELETE_WINDOW {set GMResConf 0}}

    frame $w.fr -borderwidth 5 -bg $COLOUR(confbg)
    label $w.fr.tit -text $TXT(message)
    frame $w.fr.ft
    set txt $w.fr.ft.txt
    text $txt -wrap word  -width 70 -height 10 \
	-exportselection true -yscrollcommand [list $w.fr.ft.sv set]
    $txt insert 1.0 $message
    if { $maxlength != -1 } {
	bind $txt <KeyRelease> [list TextCheckLimit $txt $maxlength bg messbg]
    }
    TextBindings $txt
    scrollbar $w.fr.ft.sv -command [list $txt yview]

    frame $w.fr.bs
    button $w.fr.bs.ok -text $TXT(ok) -command { set GMResConf 1 }
    button $w.fr.bs.cancel -text $TXT(cancel) -command { set GMResConf 0 }

    grid $txt -row 0 -column 0 -sticky nesw
    grid $w.fr.ft.sv -row 0 -column 1 -sticky ns
    pack $w.fr.bs.ok $w.fr.bs.cancel -side left -pady 5
    pack $w.fr.tit $w.fr.ft $w.fr.bs -side top -pady 5
    pack $w.fr
    update idletasks
    set gs [grab current]
    grab $w
    RaiseWindow $w
    tkwait variable GMResConf
    set message [$txt get 1.0 end]
    DestroyRGrabs $w $gs
    update idletasks
    if { $GMResConf } {
	if { $maxlength != -1 && [string length $message] > $maxlength } {
	    set message [string replace $message $maxlength end]
	}
	set cmd [list configure -verbose 0 -url $url -connecttimeout 2 \
		    -post 1 -postfields "$fieldname=$message"]
	if { $login } {
	    if { [set usrpwd [GMLogin $service]] == {} } { return 0 }
	    set usrpwd "[lindex $usrpwd 0]:[lindex $usrpwd 1]"
	    lappend cmd -userpwd $usrpwd
	}
	if { [catch {set chandle [curl::init]}] } { return 0 }
	set cmd [linsert $cmd 0 $chandle]
	if { [catch {eval $cmd}] || \
		 [catch {set res [$chandle perform]}] || \
		 [catch {$chandle reset}] } {
		return 0
	}
	return 1
    }
    return 0
}