#
# Copyright (c) 1993 and 1994 Eric Schenk.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
# 
# IN NO EVENT SHALL ERIC SCHENK BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF ERIC
# SCHENK HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# ERIC SCHENK SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND ERIC SCHENK HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

# Widgets we use in the preferences dialogs

proc change_defaults {varindex} {
    global prefs use_default
    if $use_default($varindex) {
	set prefs($varindex) [compute_default $varindex]
	# force correct display
	set use_default($varindex) 1
    }
}

proc fixed_message {path message varindex} {
    global use_default
    checkbutton $path.use_default -text "Default" -borderwidth 2 \
	-variable use_default($varindex) -command "change_defaults $varindex"
    pack $path.use_default -side left -fill x -padx 15
    frame $path.message -width 150
    label $path.message.m -text $message
    pack propagate $path.message 0
    pack $path.message.m -side right
    $path.message config -height [winfo reqheight $path.message.m]
    pack $path.message -side left -padx 5 -fill x
}

#------------------------------------------------------------------------------
# Dialog to choose a cursor.
#------------------------------------------------------------------------------

set cursorData {
X_cursor	arrow		based_arrow_down	based_arrow_up
boat		bogosity	bottom_left_corner	bottom_right_corner
bottom_side	bottom_tee	box_spiral		center_ptr
circle		clock		coffee_mug		cross
cross_reverse	crosshair	diamond_cross		dot
dotbox		double_arrow	draft_large		draft_small
draped_box	exchange	fleur			gobbler
gumby		hand1		hand2			heart
icon		iron_cross	left_ptr		left_side
left_tee	leftbutton	ll_angle		lr_angle
man		middlebutton	mouse			pencil
pirate		plus		question_arrow		right_ptr
right_side	right_tee	rightbutton		rtl_logo
sailboat	sb_down_arrow	sb_h_double_arrow	sb_left_arrow
sb_right_arrow	sb_up_arrow	sb_v_double_arrow	shuttle
sizing		spider		spraycan		star
target		tcross		top_left_arrow		top_left_corner
top_right_corner top_side	top_tee			trek
ul_angle	umbrella	ur_angle		watch
xterm
}

proc cursor {path message varindex} {
    global prefs tkwm_libpath

    if ![winfo exists .cursor] {cursor::createpopup}
    frame $path
    fixed_message $path $message $varindex
    menubutton $path.button -bitmap @$tkwm_libpath/down_arrow.xbm -relief raised -borderwidth 2
    bind $path.button <Button-1> "cursor::popup $path.button $varindex"
    label $path.value -textvariable prefs($varindex)
    pack $path.button $path.value -side left -fill x
}

proc cursor::createpopup {} {
    global cursorData tkwm_libpath

    toplevel .cursor -borderwidth 5 -relief ridge -cursor top_left_arrow
    wm withdraw .cursor
    wm overrideredirect .cursor 1

    set i 0
    set j 0
    foreach curs [concat {{}} $cursorData] {
	if {$i%9==0} {
	    incr j
	    frame .cursor.f$j
	    pack .cursor.f$j -side top -anchor w -fill x
	}
        if {$i=="0"} {
	    button .cursor.[string tolower $curs] \
		-command "cursor::popdown {}" -font cursor \
		-text [format "%c" 0] -width 2
	} else {
            if {$i=="1"} {
	    	button .cursor.[string tolower $curs] -font cursor \
		-bitmap @$tkwm_libpath/X_bitmap.xbm -command "cursor::popdown $curs" \
		-width 34 -height 33
	    } else {
	        button .cursor.[string tolower $curs] -font cursor \
		-text [format %c [expr {($i-1)*2}]] \
		-command "cursor::popdown $curs" -width 2
	    }
	}
	pack .cursor.[string tolower $curs] -in .cursor.f$j -side left -fill x -anchor w
	incr i
    }
}

proc cursor::popup {button varindex} {
    global tkwm_priv use_default
    if !$use_default($varindex) {
        if [string match [wm state .cursor] normal] {
	    wm withdraw .cursor
        } else {
            set tkwm_priv(varindex) $varindex
            wm geometry .cursor +[winfo rootx $button]+[expr {[winfo rooty $button]+[winfo height $button]}]
            wm deiconify .cursor
            raise .cursor
       }
   }
}

proc cursor::popdown {value} {
    global tkwm_priv prefs
    set prefs($tkwm_priv(varindex)) $value
    wm withdraw .cursor
}


#------------------------------------------------------------------------------
# Simple choice buttons
#------------------------------------------------------------------------------
proc boolean {path message varindex} {
    global prefs use_default

    frame $path
    fixed_message $path $message $varindex
    frame $path.choices -relief sunken -borderwidth 2
    button $path.choices.on -text On -command "boolean::set $path $varindex 1" -width 4 -borderwidth 2
    pack $path.choices.on -side left -fill x -fill y
    button $path.choices.off -text Off -command "boolean::set $path $varindex 0" -width 4 -borderwidth 2
    pack $path.choices.off -side left -fill x -fill y
    pack $path.choices -side left -fill x
    trace variable use_default($varindex) w "boolean::trace $path"
    bind $path <Destroy> [list trace vdelete use_default($-varindex) w "boolean::trace $path"]
    boolean::display $path $varindex
}

proc boolean::set {var varindex value} {
    global prefs use_default

    if [info exists use_default($varindex)] {
	if !$use_default($varindex) {
	    set prefs($varindex) $value
	    boolean::display $var $varindex
	}
    }
}

proc boolean::display {var varindex} {
    global prefs
    set value $prefs($varindex)
    if {$value=="0"} {
	$var.choices.on config -relief raised
	$var.choices.off config -relief sunken
    } else {
	$var.choices.on config -relief sunken
	$var.choices.off config -relief raised
    }
}

proc boolean::trace {path name1 name2 op} {
    boolean::display $path $name2
}


#------------------------------------------------------------------------------
# Choices among to many items to display on a line, so we put them in a menu.
#------------------------------------------------------------------------------
proc longchoice::trace {path name1 name2 op} {
    global use_default
    if $use_default($name2) {
	bind $path.choices <Button-1> { }
    } else {
	bind $path.choices <Button-1> {}
    }
}

proc longchoice {path message varindex choices} {
    global use_default tkwm_libpath

    frame $path
    fixed_message $path $message $varindex

    menubutton $path.choices -bitmap @$tkwm_libpath/down_arrow.xbm -menu $path.choices.m -relief raised -borderwidth 2
    menu $path.choices.m
    foreach c $choices {
	$path.choices.m add radiobutton -label $c -variable prefs($varindex)
    }
    label $path.value -textvariable prefs($varindex)
    pack $path.choices $path.value -side left -fill x
    trace variable use_default($varindex) w "longchoice::trace $path"
    bind $path.choices <Destroy> [list trace vdelete use_default($varindex) w "longchoice::trace $path"]
    longchoice::trace $path use_default $varindex w
}


#------------------------------------------------------------------------------
# Entry field choice widget
#------------------------------------------------------------------------------

proc entrychoice::trace {path name1 name2 op} {
    global use_default prefs
    if $use_default($name2) {
	bind $path.entry <Any-Key> { }
    } else {
	bind $path.entry <Any-KeyPress> {}
    }
}

proc entrychoice::trace2 {path name1 name2 op} {
    global prefs
    $path.entry delete 0 end
    $path.entry insert 0 $prefs($name2)
}

proc entrychoice {path message varindex} {
    global use_default prefs entrychoice_list

    lappend entrychoice_list [list $path.entry $varindex]
    frame $path
    fixed_message $path $message $varindex
    entry $path.entry  -borderwidth 2 -relief sunken -width 30
    pack $path.entry -side left -fill x
    trace variable use_default($varindex) w "entrychoice::trace $path"
    trace variable prefs($varindex) w "entrychoice::trace2 $path"
    bind $path.entry <Destroy> [list trace vdelete use_default($varindex) w "entrychoice::trace $path"]
    bind $path.entry <Destroy> [list + trace vdelete use_default($varindex) w "entrychoice::trace $path"]
    entrychoice::trace $path use_default $varindex w
    entrychoice::trace2 $path prefs $varindex w
}

proc finalize_entries {} {
    global entrychoice_list prefs
    foreach i $entrychoice_list {
	set prefs([lindex $i 1]) [[lindex $i 0] get]
    }
}

#------------------------------------------------------------------------------
# Color chooser
#------------------------------------------------------------------------------

proc colorchoice::trace {path name1 name2 op} {
    global use_default prefs
    if $use_default($name2) {
	bind $path.color <Any-Key> { }
	bind $path.color <Enter> { }
    } else {
	bind $path.color <Any-KeyPress> {}
	bind $path.color <Any-Return> "colorchoice::enter $path $name2"
    }
}

proc colorchoice::trace2 {path name1 name2 op} {
    global prefs
    $path.color delete 0 end
    $path.color insert 0 $prefs($name2)
    colorchoice::enter $path $name2
}

proc color_choice {path message varindex} {
    global use_default prefs colorchoice_list

    lappend colorchoice_list [list $path $varindex]
    frame $path
    fixed_message $path $message $varindex
    entry $path.color  -borderwidth 2 -relief sunken -width 15
    frame $path.colorsample -geometry 24x24 -background "#000000"
    pack $path.color $path.colorsample -side left -fill x -padx 2
    scale $path.r -length 255 -from 0 -to 255 -command "colorchoice::update $path $varindex"\
	-orient horizontal -showvalue 0 -width 8
    scale $path.g -length 255 -from 0 -to 255 -command "colorchoice::update $path $varindex"\
	-orient horizontal -showvalue 0 -width 8
    scale $path.b -length 255 -from 0 -to 255 -command "colorchoice::update $path $varindex"\
	-orient horizontal -showvalue 0 -width 8
    frame $path.frame
    pack $path.frame -side right -fill x -padx 8
    pack $path.r $path.g $path.b -side top

    trace variable use_default($varindex) w "colorchoice::trace $path"
    trace variable prefs($varindex) w "colorchoice::trace2 $path"
    bind $path.color <Destroy> [list trace vdelete use_default($varindex) w "colorchoice::trace $path"]
    bind $path.color <Destroy> [list + trace vdelete use_default($varindex) w "colorchoice::trace $path"]
    colorchoice::trace $path use_default $varindex w
    colorchoice::trace2 $path prefs $varindex w
    colorchoice::enter $path $varindex
}

proc colorchoice::update {path varindex val} {
  global prefs colorchoice::inhibit
  if ![info exists {colorchoice::inhibit}] {
    set color [format "#%02x%02x%02x" [$path.r get] [$path.g get] [$path.b get]]
    set prefs($varindex) $color
  }
}

proc finalize_colors {} {
    global colorchoice_list prefs
    foreach i $colorchoice_list {
	colorchoice::enter [lindex $i 0] [lindex $i 1]
    }
}

proc colorchoice::enter {path varindex} {
    global prefs colorchoice::inhibit
    set color [$path.color get]
    handleError {
	scan [winfo rgb $path.color $color] "%d %d %d" r g b
	set r [expr {$r/256}]
	set g [expr {$g/256}]
	set b [expr {$b/256}]
	set {colorchoice::inhibit} 1
	$path.r set $r
	$path.g set $g
	$path.b set $b
    	$path.colorsample config -background $color
	set prefs($varindex) $color
	update
	unset colorchoice::inhibit
    } {
	# don't change anything, refresh entry
	set prefs($varindex) $prefs($varindex)
    	$path.colorsample config -background $prefs($varindex)
    }
}

#------------------------------------------------------------------------------
# Set up aliases for a variety of "long choice" style dialogs
#------------------------------------------------------------------------------

proc manager_choice {path args} {
    set s [send_cmd {set tkwm_priv(managers)}]
    eval longchoice $path $args {$s}
}

proc button_choice {path args} {
    eval entrychoice $path $args
}

proc integer_choice {path args} {
    eval entrychoice $path $args
}

proc font_choice {path args} {
    eval entrychoice $path $args
}

proc bitmap_choice {path args} {
    eval entrychoice $path $args
}