global dlb
set dlb(curtndx) 0.0
set dlb(debug) 0

####################################################################
#
# DISJOINT.TK v1.1	- by Paul Raines
#
# This file contains code for a "listbox" using the 
# text widget that supports disjoint selection. For the
# most part, you can replace your normal 'listbox' command
# with 'disjointlistbox' with the following provisos
#
#	(1) Configuration options are those of the text
#	    widget instead of the listbox widget. This means
#	    that the following listbox options aren't supported
#		 geometry (use width and height instead)
#		 xscrollcommand (sorry, can't do it)
#		 exportselection (not with disjoint selection)
#
#       (2) All the normal widget methods are implemented except
#	    xview and select adjust. Also, in the scan mark and
#	    scan dragto methods, the x coordinate is ignored.
#
#	(3) The following commands have been expanded.
#	      curselection ?offset?
#		  - offset is added to each index before the
#		    list of selected indices is returned. This
#		    is mainly there to make my life easier in TkMail
#	      scan clear ?index?
#	          - where if index is given, only the item
#		    at that position will be cleared
#	      scan from index ?keep?
#		  - the key word 'keep' prevents other item
#		    selections from being cleared. Index is
#		    also made the primary single selection.
#	      scan to index ?keep?
#		  - the key word 'keep' prevents other item
#		    selections from being cleared
#
#	(4) The following commands have been added
#	      cursingle
#	          - returns the index of the primary single
#		    selection marked with a ">". This features
#		    makes the listbox into a single selection
#		    and multi-selection box all-in-one.
#	      scan at ?index?
#	          - select the item at index not clearing any
#		    other item and only making index the primary
#		    single selection if it is the only selection.
#	      scan toggle ?index?
#	          - toggle the selection state of item at index 
#		    not clearing any other item
#
# NOTE: be careful not to include any "\n" characters in
#	lines of text inserted into the disjoint listbox.
#	This will really screw things up.
#
# The default bindings are:
#
#	<1>	Clicked item becomes "first" and only
#		selected item
# <Shift-1>	Toggle items selection
#	<2>	Scanning
#	<3>	Clicked item becomes an additional 
#		selected item
# <Shift-3>	Clicked item becomes is deselected
# 
# <1>, <3>, & <Shift-3> can be dragged to select (or deselect)
# additional items, however, only <1> uses anchoring so that
# you can backtrack.
#
# COPYRIGHT:
#     Copyright 1993 by Paul Raines (raines@bohr.physics.upenn.edu)
#
#     Permission to use, copy, modify, and distribute this
#     software and its documentation for any purpose and without
#     fee is hereby granted, provided that the above copyright
#     notice appear in all copies.  The University of Pennsylvania
#     makes no representations about the suitability of this
#     software for any purpose.  It is provided "as is" without
#     express or implied warranty.
#
# DISCLAIMER:
#     UNDER NO CIRCUMSTANCES WILL THE AUTHOR OF THIS SOFTWARE OR THE
#     UNIVERSITY OF PENNSYLVANIA BE RESPONSIBLE FOR ANY DIRECT OR
#     INCIDENTAL DAMAGE ARISING FROM THE USE OF THIS SOFTWARE AND ITS
#     DOCUMENTATION. THE SOFTWARE HEREIN IS PROVIDED "AS IS" WITH NO
#     IMPLIED OBLIGATION TO PROVIDE SUPPORT, UPDATES, OR MODIFICATIONS.
#
# HISTORY:
#  v1.0 
#     93-08-25    released original version
#
#  v1.1
#     93-08-26	  fixed configure bug
#		  added offset option to curselection
#
###############################################################

# Might define special config options later just for disjointlistbox
# but for now, just pass them to text widget procedure
proc dlb_configure { dlbname args } {
    global dlb

    eval "${dlbname}_text configure $args"
}

# the actual creation of disjoint listbox procedure
proc disjointlistbox { dlbname args } {
    global dlb

    text ${dlbname}
    rename ${dlbname} ${dlbname}_text
    eval "dlb_configure $dlbname $args"
    ${dlbname}_text tag configure selline \
        -background [lindex [${dlbname}_text configure -selectbackground] 4] \
        -foreground [lindex [${dlbname}_text configure -selectforeground] 4] \
        -borderwidth [lindex [${dlbname}_text configure -selectborderwidth] 4] \
	-relief raised

    # Set up default bindings    
    bind ${dlbname} <Any-KeyPress> " "
    bind ${dlbname} <1> {%W select from [%W nearest %y]}
    bind ${dlbname} <B1-Motion> {%W select to [%W nearest %y]}
    bind ${dlbname} <Double-1> " "
    bind ${dlbname} <Triple-1> " "
    bind ${dlbname} <Shift-1> {%W select toggle [%W nearest %y]}
    bind ${dlbname} <Shift-B1-Motion> " "
    bind ${dlbname} <2> {%W scan mark %x %y}
    bind ${dlbname} <B2-Motion> {%W scan dragto %x %y}
    bind ${dlbname} <3> {%W select at [%W nearest %y]}
    bind ${dlbname} <B3-Motion> {%W select at [%W nearest %y]}
    bind ${dlbname} <Shift-3> {%W select clear [%W nearest %y]}
    bind ${dlbname} <Shift-B3-Motion> {%W select clear [%W nearest %y]}

    # setup the procedure
    proc $dlbname {args} "eval \"dlb_process $dlbname \$args\""

}

# setup the procedure
proc dlb_process {dlbname args} {
    global dlb

    set cnt [llength $args]
    case [lindex $args 0] {
    {configure} {
	eval "dlb_configure $dlbname [lrange $args 1 end]"
    }
    {cursingle} {
      if {$cnt == 1} {
	# return empty if no "first" selection
	if {$dlb(curtndx) == 0.0} {return ""}
	set ndx [lindex [split $dlb(curtndx) .] 0]
	return [expr $ndx-1]
      } else {
	error "wrong # args: should be $dlbname cursingle"
      } 
    }
    {curselection} {
      if {$cnt > 0 && $cnt < 3} {
	# return list of selected item indices
	if {$cnt == 2} {
	    set offset [lindex $args 1]
        } else {
	    set offset 0
	}
	set lsel ""
	set ranges [${dlbname}_text tag ranges selline]
	for {set line 0} {$line < [llength $ranges]} {incr line} {
	    set ndx [lindex [split [lindex $ranges $line] .] 0]
	    incr line
	    set last [lindex [split [lindex $ranges $line] .] 0]
	    for {set i $ndx} {$i < $last} {incr i} {
		lappend lsel [expr $i-1+$offset] 
	    }    
	}
	return $lsel
      } else {
	error "wrong # args: should be $dlbname cursingle"
      } 
    }
    {debug} { set dlb(debug) [lindex $args 1]}
    {delete} {
      if {$cnt > 1 && $cnt < 4} {
	set lndx ""
	set ndx [lindex $args 1]
	if {$ndx == "end"} {
	    set ndx [${dlbname}_text index "end-1l linestart"]
	} else {
	    set ndx [expr $ndx+1].0
	}
	if {[llength $args] == 3} {
	    if {[lindex $args 1] == "end"} {return ""}
	    set lndx [lindex $args 2]
	    if {$lndx == "end"} {
		set lndx [${dlbname}_text index "end-1l linestart"]
	    } else {
		set lndx [expr $lndx+1].0
	    }
	} else {
	    set lndx $ndx
	}
	${dlbname}_text delete $ndx "$lndx lineend +1c"

	# see if we still have "first" selection and adjust
	if {$dlb(curtndx) >= $ndx && $dlb(curtndx) <= $lndx} {
	    set dlb(curtndx) 0.0
	    set rngs [${dlbname}_text tag ranges selline]
	    if {$rngs != ""} {
	      foreach tndx $rngs {
		if {$ndx <= $tndx} {
		  set dlb(curtndx) $tndx
		  break
		}
	      }
	      if {$dlb(curtndx) == 0.0} {
		set tndx [lindex $rngs [expr [llength $rngs]-1]]
		set dlb(curtndx) [${dlbname}_text index $tndx-1l]
	      }
	      ${dlbname}_text insert $dlb(curtndx)+1c ">"
	      ${dlbname}_text delete $dlb(curtndx)
	    }
	} elseif {$dlb(curtndx) > $lndx} {
	    set tmp [expr [lindex [split $lndx .] 0]-[lindex $args 1]]
	    set dlb(curtndx) [${dlbname}_text index $dlb(curtndx)-${tmp}l]
	}
	return ""
      } else {
	error "wrong # args: should be $dlbname delete first ?last?"
      } 
    }
    {get} {
      if {$cnt == 2} {
	set ndx [lindex $args 1]
	if {$ndx == "end"} {
	    set ndx [${dlbname}_text index "end-1l linestart"]
	} else {
	    set ndx [expr $ndx+1].0
	}
	return [${dlbname}_text get $ndx+1c "$ndx lineend"]
      } else {
	error "wrong # args: should be $dlbname get index"
      } 
    }
    {insert} {
      if {$cnt > 2} {
	set ndx [lindex $args 1]
	if {$ndx == "end"} {
	    set ndx [${dlbname}_text index end]
	} else {
	    set ndx [expr $ndx+1].0
	}
	foreach line [lrange $args 2 end] {
	    ${dlbname}_text insert $ndx " $line\n"
	    set ndx [${dlbname}_text index $ndx+1l]
	}
	return ""
      } else {
        if {$cnt == 1} {
	  error "wrong # args: should be $dlbname insert index ?element ...?"
	}
      } 
    }
    {nearest} {
      if {$cnt == 2} {
	set y [lindex $args 1]
	set ndx [${dlbname}_text index @0,$y]
	set ndx [expr [lindex [split $ndx .] 0]-1]
	set sz [${dlbname}_text index end]
	set sz [expr [lindex [split $sz .] 0]-1]
	if {$ndx >= $sz} {set ndx [expr $sz-1]}
	return $ndx
      } else {
	error "wrong # args: should be $dlbname nearest y"
      } 
    }
    {scan} {
      if {$cnt == 4} {
	set cmd [lindex $args 1]
	set y [lindex $args 3]
	if {$cmd == "mark"} {
	    ${dlbname}_text scan mark $y
	} elseif {$cmd == "dragto"} {
	    ${dlbname}_text scan dragto $y
	} else {
	    error "bad scan option: must be mark, dragto"
	}
      } else {
	error "wrong # args: should be $dlbname scan mark|dragto x y"
      } 
    }
    {select} {
	set lastcur $dlb(curtndx)
	case [lindex $args 1] {
	{adjust} {
	    if {$dlb(debug)} {
	        puts stderr "select adjust option to ${dlbname} ignored"
	    }
	}
	{at} {
	  if {$cnt == 3} {
	    set ndx [expr [lindex $args 2]+1].0
	    ${dlbname}_text tag add selline $ndx \
		[${dlbname}_text index "$ndx lineend + 1 chars"]
	    if {$dlb(curtndx) == 0.0} {
	        set dlb(curtndx) $ndx
	    }
	  } else {
	    error "wrong # args: should be $dlbname select at index"
	  }
	}
	{clear} {
	  if {$cnt > 1 && $cnt < 4} {
	    if {[llength $args] == 2} {
		${dlbname}_text tag remove selline 0.0 end
		set dlb(curtndx) 0.0
	    } else {
	        foreach tndx [lrange $args 2 end] {
		    set ndx [expr $tndx+1].0
		    ${dlbname}_text tag remove selline $ndx \
			[${dlbname}_text index "$ndx lineend + 1 chars"]
		    if {$dlb(curtndx) == $ndx} {
			set dlb(curtndx) 0.0
		    }
		}
		set rngs [${dlbname}_text tag ranges selline]
		if {$dlb(curtndx) == 0.0 && $rngs != ""} {
		  foreach tndx $rngs {
		    if {$ndx < $tndx} {
		      set dlb(curtndx) $tndx
		      break
		    }
		  }
		  if {$dlb(curtndx) == 0.0} {
		    set tndx [lindex $rngs [expr [llength $rngs]-1]]
		    set dlb(curtndx) [${dlbname}_text index $tndx-1l]
		  }
		}
	    }
	  } else {
	    error "wrong # args: should be $dlbname select clear ?index?"
	  }
	}
	{from} {
	  if {$cnt == 3 || ($cnt == 4 && [lindex $args 3] == "keep")} {
	    set ndx [expr [lindex $args 2]+1].0
	    if {$cnt == 3} {
	        ${dlbname}_text tag remove selline 0.0 end
	    }
	    ${dlbname}_text tag add selline $ndx \
		[${dlbname}_text index "$ndx lineend + 1 chars"]
	    set dlb(curtndx) $ndx
	  } else {
	    error "wrong # args: should be $dlbname select from index ?keep?"
	  }
	}
	{to} {
	  if {$cnt == 3 || ($cnt == 4 && [lindex $args 3] == "keep")} {
	    if {$dlb(curtndx) == 0.0} {
		eval "$dlbname select from [lrange $args 2 end]"
	    } else {
		set ndx [expr [lindex $args 2]+1].0
		set anchor $dlb(curtndx)
		if {$cnt == 3} {
		    ${dlbname}_text tag remove selline 0.0 end
		}
		if {$ndx < $anchor} {
		   ${dlbname}_text tag add selline $ndx \
		       [${dlbname}_text index "$anchor lineend + 1 chars"]
		} else {
		   ${dlbname}_text tag add selline $anchor \
		       [${dlbname}_text index "$ndx lineend + 1 chars"]
		}
	    }
	  } else {
	    error "wrong # args: should be $dlbname select to index ?keep?"
	  }
	}
	{toggle} {
	  if {$cnt == 3} {
	    set ndx [expr [lindex $args 2]+1].0
	    if {[lsearch [${dlbname}_text tag names $ndx] selline] == -1} {
	       $dlbname select at [lindex $args 2]
	    } else {
	       $dlbname select clear [lindex $args 2]
	    }
	  } else {
	    error "wrong # args: should be $dlbname select toggle index "
	  }
	}
	default {
	    error "bad select option: must be at, clear, from, to, toggle"
	    }
	}
	if {$dlb(curtndx) != $lastcur} {
	    if {$lastcur != 0.0} {
	        ${dlbname}_text insert $lastcur+1c " "
	        ${dlbname}_text delete $lastcur
	    }
	    if {$dlb(curtndx) != 0.0} {
	        ${dlbname}_text insert $dlb(curtndx)+1c ">"
	        ${dlbname}_text delete $dlb(curtndx)
	    }
	}
	return ""
    }
    {size} {
      if {$cnt == 1} {
	set ndx [${dlbname}_text index end]
	return [expr [lindex [split $ndx .] 0]-1]
      } else {
	error "wrong # args: should be $dlbname size"
      } 
    }
    {xview} {
	if {$dlb(debug)} {
	    puts stderr "xview option to ${dlbname} ignored"
	}
    }
    {yview index compare} {
	eval "${dlbname}_text $args"
    }
    default {
	puts stderr "bad option \"[lindex $args 0]\": should be [list \
	  cursingle, curselection, delete, get, insert, nearest, scan, \
          select, size, or yview]"
	}
    }
}

