
##------------------------------------------------------------------------
## PROCEDURE
##	sortedlistbox
##
## DESCRIPTION
##	Implements a SortedlistBox mega-widget
##
## ARGUMENTS
##	sortedlistbox <window pathname> <options>
##
## OPTIONS
##	(Any entry widget option may be used in addition to these)
##
##
## -masters list
##     Names of the masters of the list
##
##
##
## RETURNS: the window pathname
##
## pack [sortedlistbox .sortedlist]
## pack [sortedlistbox .sortedlist -width 20 -masters "name adress telephone"]
##
##------------------------------------------------------------------------

#  bind SortedlistEntry <Double-1> { %W popup }
#  # bind SortedlistEntry <Escape>   { %W popup }
#  # tab only is activated if -tabexpand is on
#  #bind SortedlistEntry <Tab>      { %W expand [%W get]; break }
#  bind SortedlistEntry <Up>      { %W nextprev -1; break }
#  bind SortedlistEntry <Down>      { %W nextprev 1; break }
#  bind SortedlistEntry <Return>   { %W add [%W get] }

#  bind SortedlistList <Escape>   { wm withdraw [winfo toplevel %W] }
#  bind SortedlistList <1> { tkSortedlistGet %W [%W get [%W nearest %y]] }
#  bind SortedlistList <Return>   { tkSortedlistGet %W [%W get active] }

#  bind SortedlistTopLevel <1> { wm withdraw [winfo toplevel %W]}

   bind SortedlistBox <Destroy> { tkSortedlistDestroy %W }

#  bind SortedlistBox <FocusIn> { tkSortedlistFocusToEntry %W }


proc sortedlistbox {w args} {
    global uparrowdata

    frame $w -class SortedlistBox -width 50 -height 50

    upvar \#0 $w data

    array set data {
	-masters   {}
    }
    array set data [list \
	    frameslist      "" \
	    listboxcmd		.$w.f0.l \
	    framecmd            .$w \
	    lastbuttonpressed "" \
	    lastorder         "" \
            arrowup "" \
            arrowdown "" \
	    scrollbar "" \
	    ]
    
    grid propagate $w 0
    rename $w .$w

    set data(scrollbar) [scrollbar $w.s -command "tkSortedlistScroll $w" \
	    -orient v]

    if {[string comp {} $args] && \
	    [catch {eval tkSortedlist_configure $w $args} err]} {
	destroy $w
	unset data
	return -code error $err
    }

    set im1 [image create bitmap -data {
	#define uparrow16x16_width 16
	#define uparrow16x16_height 7
	static unsigned char uparrow16x16_bits[] = {
	    0x80, 0x01, 0x40, 0x02, 0x20, 0x04, 0x10, 0x08, 0x0c, 0x30, 0x02, 0x40,
	    0xff, 0xff};
	}]

    set data(arrowup) [label $w.up -image $im1]
    set im2 [image create bitmap -data {
	#define downarrow16x16_width 16
	#define downarrow16x16_height 7
	static unsigned char downarrow16x16_bits[] = {
	    0xff, 0xff, 0x03, 0xc0, 0x04, 0x20, 0x18, 0x18, 0x20, 0x04, 0xc0, 0x03,
	    0x80, 0x01};
	}]

    set data(arrowdown) [label $w.down -image $im2]

    ## Gotta watch what you put in this list
#      bindtags $entry [list $w $entry SortedlistEntry Entry [winfo toplevel $w] all]
#      bindtags $data(listbox) [linsert [bindtags $data(listbox)] 1 SortedlistList]
#      bindtags $data(toplevel) [linsert [bindtags $data(toplevel)] 1 SortedlistTopLevel]
    
    proc $w args "eval tkSortedlistEval [list $w] \$args"
#    proc $entry args "eval tkSortedlistEval [list $w] \$args"
    
    bind $w <Configure> "after idle tkSortedlistCheckScroll $w"

    return $w
}

proc tkSortedlistCheckScroll { w } {
    upvar \#0 $w data

    update
    set len [llength $data(frameslist)]
    set listbox [join [list [lindex $data(frameslist) 0] ".l"] ""]
    if { ![winfo exists $listbox] } { return }

    set big 0
	set y -1
    if { [$listbox size] != 0 && [winfo ismapped $listbox] } {
	foreach "x y width height" [$listbox bbox 0] ""
	if { $y == -1 } { set big 1 }
	set y -1 ; set height -1
	foreach "x y width height" [$listbox bbox end] ""
	if { $y == -1 } { set big 1 }
	if { [winfo height $listbox] > 1 && [winfo height $listbox] <= \
		[expr $y+$height] } { set big 1}
    }
    if { !$big } {
	catch { grid forget $data(scrollbar) }
    } else {
	grid $data(scrollbar) -row 0 -column $len -sticky ns
    }

}

proc tkSortedlistScroll { w args } {
    upvar \#0 $w data

    foreach i $data(frameslist) {
	set listbox $i.l
	eval [concat $listbox yview $args]
    }
    
}

proc tkSortedlistButtonPressed { w but } {
    upvar \#0 $w data
    
    set ipos [lsearch $data(frameslist) [winfo parent $but]]
    set basel [join [list [lindex $data(frameslist) 0] ".l"] ""]
    set numl [llength $data(frameslist)]
    set size [$basel size]
    set neworder -increasing
    if { $but == $data(lastbuttonpressed) && $data(lastorder) == "-increasing" } {
	set neworder -decreasing
    }
    set list ""
    for { set i 0 } { $i < $size } { incr i } {
	set element ""
	for { set j 0 } { $j < $numl } { incr j } {
	    set listbox [join [list [lindex $data(frameslist) $j] ".l"] ""]
	    lappend element [$listbox get $i]
	}
	lappend list $element
    }
    set list [lsort -dictionary $neworder -index $ipos $list]
    for { set j 0 } { $j < $numl } { incr j } {
	set listbox [join [list [lindex $data(frameslist) $j] ".l"] ""]
	$listbox del 0 end
    }
    for { set i 0 } { $i < $size } { incr i } {
	set element [lindex $list $i]
	for { set j 0 } { $j < $numl } { incr j } {
	    set listbox [join [list [lindex $data(frameslist) $j] ".l"] ""]
	    $listbox ins end [lindex $element $j]
	}
    }

    if { $neworder == "-increasing" } {
	place $data(arrowdown) -in $but -relx 1 -x -0 -anchor e -rely .5
	place forget $data(arrowup)
    } else {
	place $data(arrowup) -in $but -relx 1 -x -0 -anchor e -rely .5
	place forget $data(arrowdown)
    }

    set data(lastbuttonpressed) $but
    set data(lastorder) $neworder
}

proc tkSortedlistEval { w args } {
  upvar \#0 $w data

  switch -glob -- [lindex $args 0] {
    {} {
      return -code error "wrong \# args: should be \"$w option ?arg ...?\""
    }
    conf*	{ set ret [eval tkSortedlist_configure $w [lrange $args 1 end]] }
    cg*		{ set ret [eval tkSortedlist_cget $w [lrange $args 1 end]] }
    ins*	{ set ret [eval tkSortedlist_ins $w [lrange $args 1 end]] }
    get		{ set ret [eval tkSortedlist_get $w [lrange $args 1 end]] }
    del*	{ set ret [eval tkSortedlist_del $w [lrange $args 1 end]] }
    sel*        { set ret [eval $data(listboxcmd) $args] }
    size        { set ret [eval $data(listboxcmd) $args] }
    listbox     { set ret $data(listboxcmd) }
    default	{ set ret [eval $data(framecmd) $args] }
  }
  tkSortedlistCheckScroll $w
  return $ret
}

proc tkSortedlistDestroy w {
    upvar \#0 $w data
    #tkSortedlistReleaseGrab $w
    catch { rename $w {}; unset data }
}

proc tkSortedlist_configure { w args } {
  upvar \#0 $w data

  set num [llength $args]
  if {$num==1} {
    set arg [array names data ${args}*]
    set num [llength $arg]
    if {$num==1} {
      return [list $arg {} {} {} $data($arg)]
    } elseif $num {
      return -code error "ambiguous option \"$args\""
    } elseif [catch {$data(framecmd) config $args} err] {
      return -code error $err
    } else {
      return $err
    }
  } elseif $num {
    set truth {^(1|yes|true|on)$}
    for {set i 0;set cargs {}} {$i<$num} {incr i} {
      set arg [string tolower [lindex $args $i]]
      set val [lindex $args [incr i]]
      switch -glob -- $arg {
	  -masters      {
	      set data(-masters) $val
	      set ipos 0
	      set len [llength $data(-masters)]
	      foreach imaster $data(-masters) {
		  set frame [lindex $data(frameslist) $ipos]
		  if { $frame == "" } {
		      set frame [frame $w.f$ipos -bd 0 -highlightthickness 0]
		      lappend data(frameslist) $frame
		      set but $w.f$ipos.b
		      button $but -text $imaster -pady 0 -bd 1 \
			      -anchor w -padx 2 \
			      -command "tkSortedlistButtonPressed $w $w.f$ipos.b"
		      bind $but <Motion> \
			      "tkSortedlistButtMotion $w $but $ipos %x"
		      bind $but <ButtonPress-1> \
			      "tkSortedlistBeginMoveSep $w $but $ipos %x %X; break"

		      bind $but <Configure> "\
			      set len [font measure [$but cget -font] [$but cget -text]] ;\
			      if { \[expr \$len+10] > \[winfo width $but] } { \
			         $but conf -text \"[string range [$but cget -text] 0 3]...\" ; \
			     } else { \
			         $but conf -text \"[$but cget -text]\" \
                             }"

		      set listbox [listbox $w.f$ipos.l -selectmode extended \
			      -highlightthickness 0 -bd 0]
  		      if { $ipos == 0 } {
			  set data(listboxcmd) $listbox
  			  $listbox conf -yscrollcommand "$data(scrollbar) set"
  		      }
		      if { $ipos > 0 } {
			  foreach k [bind Listbox] {
			      # bind to nothing
			      bind $listbox $k "break"
			  }
		      }
		      grid $but -row 0 -column 0 -sticky ew
		      grid $listbox -row 1 -column 0 -sticky nsew
		      grid columnconf $frame 0 -weight 1
		      grid rowconf $frame 1 -weight 1
		      grid $frame -row 0 -column $ipos -sticky ewns
		      grid propagate $frame 0
		      grid columnconf $w $ipos -weight 1
		      grid rowconf $w 0 -weight 1
		  }
		  
		  incr ipos
	      }
	      if { [winfo exists $w.s[expr $ipos-1]] } {
		  destroy $w.s[expr $ipos-1]
	      }
	      while { [winfo exists $w.b$ipos] } {
		  destroy $w.b$ipos
		  destroy $w.s$ipos
		  destroy $w.l$ipos
		  incr ipos
	      }
	  }
	-editable	{
	  if [set data(-editable) [regexp $truth $val]] {
	    $data(entrycmd) config -state normal
	  } else {
	    $data(entrycmd) config -state disabled
	  }
	}
	-grab		{ regexp {^(local|global)$} $val data(-grab) }
	-keephistory	{ set data(-keephistory) [regexp $truth $val] }
	-history	{
	  set data(-history) $val
	  $data(listbox) delete 0 end
	  eval $data(listbox) insert end $val
	}
	-tabexpand	{ 
	    set data(-tabexpand) $val
	    if { $val } {
		bind $data(entrycmd) <Tab> { %W expand [%W get]; break }
	    } else {
		bind $data(entrycmd) <Tab> ""
	    }
	}
	-prunehistory	{ set data(-prunehistory) [regexp $truth $val] }
	-state          {
	    if { $val == "normal" } {
		set data(-state) normal
		$data(button) conf -state normal
		if { $data(-editable) == 1 } { 
		    $data(entrycmd) config -state normal
		}
	    } elseif { $val == "disabled" } {
		set data(-state) disabled
		$data(button) conf -state disabled
		$data(entrycmd) config -state disabled
	    } else {
		return -code error \
	"wrong \# args: should be \"$w configure -state enabled|disabled\""
	    }
	}
	default	{ lappend cargs $arg $val }
      }
    }
    if {[string comp {} $cargs] && \
	[catch {eval $data(framecmd) config $cargs} err]} {
	return -code error $err
    }
    return
  } else {
    set conf [$data(framecmd) config]
    foreach i [array names data -*] {
      lappend conf [list $i {} {} {} $data($i)]
    }
    return [lsort $conf]
  }
}

proc tkSortedlist_cget { w args } {
  if {[llength $args] != 1} {
    return -code error "wrong \# args: should be \"$w cget option\""
  }
  upvar \#0 $w data

  set arg [array names data $args]
  set num [llength $arg]
  if { $num != 1 } {
      set arg [array names data ${args}*]
      set num [llength $arg]
  }
  if {$num==1} {
    return $data($arg)
  } elseif $num {
    return -code error "ambiguous option \"$args\""
  } elseif [catch {$data(framecmd) cget $args} err] {
    return -code error $err
  } else {
    return $err
  }
}


proc tkSortedlist_ins {w index args} {
    upvar \#0 $w data

    set ipos 0
    foreach j $args {
	if { [llength $j] != [llength $data(-masters)] } {
	    return -code error "number of elements in add different from master"
	}
	foreach i $j {
	    set listbox [join [list [lindex $data(frameslist) $ipos] ".l"] ""]
	    $listbox ins $index $i
	incr ipos
	}
    }
}

proc tkSortedlist_get {w first { last -1 } } {
    upvar \#0 $w data
    
    set listbox [join [list [lindex $data(frameslist) 0] ".l"] ""]

    set retval ""

    if { $first >= [$listbox index end] } { return "" }
    if { $last == -1 } { set last $first }
    set lastidx [$listbox index $last]
    if { $last == "end" } { incr lastidx -1}
    for { set i $first } { $i <= $lastidx } { incr i } {
	set element ""
	foreach j $data(frameslist) {
	    lappend element [$j.l get $i]
	}
	lappend retval $element
    }
    return $retval
}

proc tkSortedlist_del {w args} {
    upvar \#0 $w data
    
    set listbox [join [list [lindex $data(frameslist) 0] ".l"] ""]

    foreach j $data(frameslist) {
	eval [concat $j.l del $args]
    }
}


proc tkSortedlistButtMotion { w but ipos x } {
    upvar \#0 $w data

    set len [llength $data(frameslist)]
    set minx 0
    if { $ipos > 0 } { set minx 10 }
    set maxx [winfo width $but]
    if { $ipos < [expr $len-1] } { incr maxx -10 }
    if { $x >= $minx && $x <= $maxx } { 
	$but conf -cursor ""
    } else {
	$but conf -cursor sb_h_double_arrow
    }

}

proc tkSortedlistBeginMoveSep { w but ipos x X } {
    upvar \#0 $w data

    set len [llength $data(frameslist)]
    
    set minx 0
    if { $ipos > 0 } { set minx 10 }
    set maxx [winfo width $but]
    if { $ipos < [expr $len-1] } { incr maxx -10 }
    if { $x >= $minx && $x <= $maxx } { 
	tkButtonDown $but 
	return
    }

    set par $but
    set xp [expr [winfo x $par]+[$par cget -bd]+$x]
    while 1 {
	if { $par == [winfo toplevel $par] } { break }
	set par [winfo parent $par]
	incr xp [expr [winfo x $par]-[$par cget -bd]]
    }

    if { $x > $maxx } { incr ipos }
    set iprev [expr $ipos-1]
    set widthleft  [winfo width [lindex $data(frameslist) $iprev]]
    set widthright [winfo width [lindex $data(frameslist) $ipos]]
    bind all <B1-Motion> "tkSortedlistMoveSep $w $ipos %X $X $widthleft $widthright"
    bind all <ButtonRelease-1> "bind all <B1-Motion> {} ; bind all \
	    <ButtonRelease-1> {} ; break"
}

proc tkSortedlistMoveSep { w ipos x xp widthleft widthright} {
    upvar \#0 $w data

    set iprev [expr $ipos-1]
    
    set delta [expr $x-$xp]

    if { $delta < [expr -$widthleft+25] } { set delta [expr -$widthleft+25] }
    if { $delta > [expr $widthright-25] } { set delta [expr $widthright-25] }

    set neww1 [expr $widthleft+$delta]
    set neww2 [expr $widthright-$delta]
    set frame1 [lindex $data(frameslist) $iprev]

    for { set i 0 } { $i < [llength $data(frameslist)] } { incr i } {
	if { $i == $iprev } {
	    grid columnconf $w $i -weight $neww1
	} elseif { $i == $ipos } {
	    grid columnconf $w $i -weight $neww2
	} else {
	    set frame [lindex $data(frameslist) $i]
	    grid columnconf $w $i -weight [winfo width $frame]
	}
    }
}

#  set tk_strictMotif 1

#  sortedlistbox .t -masters "hola adeu aqui" -bd 6 -relief groove
#  .t add "A 2fdgdsfg w"
#  .t add "B 1asdfsadf s"
#  .t add "B 1asdfsadf s"
#  .t add "S 1asdfsadf s"
#  .t add "B 1asdfsadf s"
#  .t add "H 1asdfsadf t"
#  pack .t -fill both -expand 1
#  wm geom . 400x200

