#
#  gpsman --- GPS Manager: a manager for GPS receiver data
#
#  Copyright (c) 2001 Miguel Filgueiras (mig@ncc.up.pt) / Universidade do Porto
#
#    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 2 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:  25 October 2001
#
# Includes contributions by Brian Baulch (baulchb@onthenet.com.au)
#  marked "BSB contribution"
#

## operations on menus

proc FillMenu {menu commd descr} {
    # entry point for recursive call of FillMenuRec
    #  $menu is the parent menu to fill in
    #  $commd is the callback to associate to each terminal entry
    #    whose arguments will be 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 $commd $descr
    return
}

proc FillMenuRec {w menu commd 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" != "---" } {
		  $menu add command -label "$item" \
			  -command [list $commd $item $w]
		} 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 "$commd" [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
    global GRIDS TXT MAXMENUITEMS

    if { [winfo exists $menu] } {
	$menu delete 0 end
    }
    set n 0 ; set m 0
    foreach f [concat "DMS DMM DDD UTM/UPS MH" $GRIDS] {
	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] $args]
	incr n
    }
    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 DestroyAll {w subws} {
    # destroy all sub-windows in $subws of window $w

    foreach s $subws { destroy $w.$s }
    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
}

## operations on entries

proc CheckEntries {errproc 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)

    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 } {
	    set r [linsert $r end "$info"]
	} else {
	    focus $w
	    return nil
	}
    }
    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 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 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 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
}

## 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 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 Balloon {lst} {
    global BalloonStart BalloonHelp

    if { $BalloonHelp } {
	set BalloonStart [after 2000 "BalloonCreate 5000 $lst"]
    }
    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)
	    }
	}
    }
    destroy .balloon
    toplevel .balloon
    wm resizable .balloon 0 0
    wm overrideredirect .balloon 1
    wm geometry .balloon +$BalloonX+$BalloonY
    label .balloon.mess -text $mess -relief groove -bg $COLOUR(ballbg) \
	    -fg $COLOUR(ballfg)
    pack .balloon.mess
    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
}

## 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 Multiply {x y} {

    return [expr $x*$y]
}

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

    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

    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 Luís 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 when writing

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
    while { "$list" != "" } {
	if { $n != 0 } { puts -nonewline $file " " }
	WriteQuote $file [lindex $list 0]
	set list [lreplace $list 0 0]
	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 "\""
    regsub -all {"} $string "\\\"" new
    puts -nonewline $file ${new}\"
    return
}
