# <20221223.1734.44>
# --------------------------------
#
# a minimal multi listboxes megawidget
#
# --------------------------------

#    namespace export multilist

# -----------------
# the constructor
# -----------------
#
# calling sequence:
#
# multilist window listboxes ?-font font? 
#                            ?-lcolor listbgcolor? 
#                            ?-tcolor titlebgcolor?  
#                            ?-toptions 'option list'  
#                            ?-loptions 'option list' 
#                            ?-boptions 'option list'
#                            ?-selectscript 'script'?
#                            ?-listcolumnscroll 0/1 ?
#                            ?-soptions 'option list'?
# Where 'option list' is a list of couples to pass to the title (toptions) or
# the list box (loptions) or the button (sw corner) or the listcolumn 
# scrollbar (listcolumnscroll) window creation code.  
# This list should be quoted. For the button it can be bitmap as well as
# a command e.g. "-text X -command <command name> args".  The button label is
# $w.v.but where $w is the 'window' in the call.  This is not in the return 
# information.
# The script given by the -selectscript option is called when ever the 
# selection is changed.  The script will be called with two arguments:
# The window name (as returned on the inital call) and a list of the
# selected entries from 'window selection get' command.
#
# window is the base window to build the multilist boxes in
# listboxes is the name of a global (call-by-name) which contains 
# a list of 3 element lists that describe the list boxes
# each list should contain the 'window name suffix' 'window width' 'title'
# e.g. for a three list call: 
#            {{cmd 20 command} {cat 10 catergory} {des 30 description}}
# this list is maintained as the list boxes are resized and move such that
# the same configuration may be re-established (the reason it is call-by-name).
#
# WINDOW NAMING CONVENTIONS:
# The return value is the window prefix to use to manupliate the windows
# thus e.g. (using the above structure):
# set mlw [multilist ...]
# $mwl.cmd insert end "text"
# I.e the listbox window is <prefix>.<first element>
# There are other windows:
# <prefix>label<first element>    is the label window
# <prefix>hscroll<first element>  is the optional scroll bar for that sub window
# $w.v (where $w is the window in the origional call) is the button window
#
# bindtags for the listboxes are expanded to include as the second entry "MultiListbox"
# i.e. bindtags for $mlw.cmd woud be {$mlw.cmd MultiListbox Listbox . all} (assuming
# "." is the top level for $mlw).

proc multilist {w listboxes args}  {
  namespace eval $w:multilist  {
    # realWaitForIdle
    # proc putx {mess} {
    #   # return
    #   puts "$mess"
    #   flush stdout
    # }
    proc do_multilist {w listboxes args } {
      # Define a 'variable' array with name ""
      variable {}
      # variables
      set (baseWindow) $w
      set (windowSizeActive) 0
      set (windowSizeTossed) 0
      set (windowSizeNow) 0
      set (yview) 0
      set (started) 0
      set (resizing) 0
      set (win) "-."
      set (lnspace) 1
      set (selectscript) "return"
      set (minsWidth) 0
      set (minWidth) 0
      set (minCWidth) 2
      set (listColumnScroll) 0
      # options
      set loptions ""
      set toptions ""
      set boptions ""
      set (soptions) ""
      set font {Courier -12}
      # (order) contains the name of the listbox list
      set (order) $listboxes
      upvar #0 $(order) listboxlist
      # frputs "[namespace current] " (order) listboxlist
      foreach {key value} $args {
#	puts "$key $value"
	switch -glob -- $key {
	  -font     {set font $value }
	  -lcolor   {lappend loptions -bg $value}
	  -tcolor   {lappend toptions -bg $value}
	  -loptions {lappend loptions {*}$value}
	  -toptions {lappend toptions {*}$value}
	  -boptions {lappend boptions {*}$value}
	  -listcolumnscroll {set (listColumnScroll) $value}
	  -selectscript {set (selectscript) $value}
	  -soptions  {lappend (soptions) {*}$value}
	}
      }
      if {$(listColumnScroll)} {
	set (gridColScroll) \
	    {grid $wc.hscroll$win -column $j\
		 -row $(listColumnScroll) -sticky ew ; }
	set (degridColScroll) {$wc.hscroll$win}
      } else {
	set (gridColScroll) ""
	set (degridColScroll) ""
      }
      set (nocol) [llength $listboxlist]
      set (chwidth) [font measure $font 0]
      # widgets
      # $w.top holds the scroll bars and the canvas ($w.top.ca)
      # $w.top.ca (the canvas) holds the multilist window ($w.top.c)
      frame $w.top -bd 0
      canvas $w.top.ca \
 	  -scrollregion {0 0 1000 0} \
	  -xscrollincrement 0 \
	  -xscrollcommand "$w.sb set" 
      scrollbar $w.sb \
	  -orient horizontal \
	  -relief sunken \
	  -command "$w.top.ca xview "
      grid propagate $w 0
      set wc $w.top.c
      set (wc) $wc
      frame $w.v -bd 0
      eval [list button $w.v.but {*}$boptions]
      scrollbar $w.v.vs -relief sunken -command [namespace code [list yview $wc]]
      
       # startProc "After canvas build "
      
      pack $w.v -side right -fill both
      pack $w.v.vs -side top -fill y -expand 1
      pack $w.v.but -side bottom -fill both
      pack $w.sb -side bottom -fill x
#      pack $w.vs -side right -fill y
      pack $w.top -fill both -expand 1
      pack $w.top.ca -fill both -expand 0
      
       # startProc "After canvas pack "

      frame $wc -bd 0 -cursor sb_h_double_arrow -bd 0 -bg black
      set item [$w.top.ca create window 0 0  -anchor nw -window $wc]
      
      foreach listbox $listboxlist {
	lassign  [subst $listbox] wi width title
	# frputs wi width title loptions (soptions)
        eval [list label $wc.label$wi \
		  -width 0\
		  -bd 0 \
		  -relief ridge \
		  {*}$toptions \
		  -cursor arrow \
		  {*}[expr {[string trim $title] == "" ? "" : [list -text $title]}]
	     ]
	
	 # startProc "After eval label "
	
	bind $wc.label$wi <ButtonPress-1> \
	    [namespace code [list reorderstart  $wc.label$wi $wi $wc %x]]
	bind $wc.label$wi <ButtonRelease-1> \
	    [namespace code [list reorderstop   $wc.label$wi $wi $wc %x]]
	# frputs
	eval [list listbox $wc.$wi \
		  -yscrollc  [namespace code [list yscroll $w.v]]\
		  -width $width \
		  -bd 0 \
		  -cursor arrow \
		  {*}$loptions \
		  -exportselection 0 ]
	
	 # startProc "After eval listbox "

	if {$(listColumnScroll)} {
	  $wc.$wi config -xscrollc [namespace code  [list $wc.hscroll$wi set]]
	  eval [list scrollbar $wc.hscroll$wi \
		    -orient horizontal \
		    -relief sunken \
		    {*}$(soptions) \
		    -command [namespace code  [list $wc.$wi xview]] ]
	}
	
	 # startProc "After eval scrollbar "
	
	# bind the select events
	# frputs
	bindtags $wc.$wi [linsert [bindtags $wc.$wi] 1 "MultiListbox"]
	bind $wc.$wi <<ListboxSelect>> [namespace code [list synchro $wi]]
      }
      set (fixHeight) [winfo reqheight $wc.label[lindex $listboxlist 1 0]]
      doGrid
      # frputs
      
       # startProc "After doGrid "

      if {$(listColumnScroll)} {
        # putx "f[realWaitForIdle]"
	update idletasks
	# startProc "After update idletasks1 "
	eval [list $wc.hscroll[lindex $listboxlist 1 0] configure\
		  -relief sunken {*}$(soptions)]
	# putx "After eval"
	## putx "s[realWaitForIdle]"
	# startProc "After eval/wait"
	update idletasks
	
	# startProc "After update idletasks2 "
	
	incr (fixHeight) [winfo reqheight $wc.hscroll[lindex $listboxlist 1 0]]
	set (minsWidth) [winfo reqwidth $wc.hscroll[lindex $listboxlist 1 0]]
      }
      newFont $font
      # bind the Motion event
      bind $wc    <ButtonPress-1>   [namespace code [list start  $wc %x]]
      bind $wc    <ButtonRelease-1> [namespace code stop ]
      bind $wc    <Motion>          [namespace code [list resize $wc %x]]
      bind $w.top <Configure>       [namespace code [list windowSize <config> ]]
      # return ref
      return $wc
    }
    # -----------------
    # Grid the windows
    # -----------------
    proc doGrid {} {
      variable {}
      foreachBut ".-" {
	incr j 0
	grid $wc.label$win  -column $j -row 0 -padx [list 0 $(chwidth)] -sticky ew
	grid $wc.$win    -column $j -row 2 -sticky ens
	eval $(gridColScroll)
	incr j
      }
#      set wc $(baseWindow).top.c
      windowSize grid $(baseWindow)
    }
    proc reGrid { } {
      variable {}
      foreachBut ".-" {
	grid remove $wc.label$win $wc.$win {*}[subst $(degridColScroll)]
      }
      doGrid
    }
    # -----------------
    # the scroll procs
    # -----------------
    # called by a listbox
    proc yscroll {w args} {
      variable {}
      if {![winfo exists $w.vs]} { return }
      eval [linsert $args 0 $w.vs set]
      yview $(wc) moveto [lindex [$w.vs get] 0]
    }
    # called by the scroll bar
    proc yview {w args} {
      variable {}
      upvar #0 $(order) listboxlist
      if {$(yview)} { return }
      set (yview) 1
      foreachBut "-." {
	upvar args args
	$wc.$win yview {*}$args
      }
      set (yview) 0
    }
    # called by a select event
    proc synchro {w } {
      variable {}
      # putx "syncro"
      upvar #0 $(order) listboxlist
      set sel [$(baseWindow).top.c.$w cursel]
      foreachBut $w {
	upvar sel sel
	$wc.$win selection clear 0 end
	foreach item $sel {
	  $wc.$win selection set $item
	}
      }
      eval {$(selectscript) $(baseWindow).top.c $sel}
    }
    # -----------------
    # The window size has changed
    # -----------------
    #
    # Some notes... We get size changes as they happen (would rather have
    # a button up on them).  To prevent overload and nasty errors from the
    # TK manager, we try to ignor as many of them as we can.  We do this
    # with the 'after' command and a set of vars that tracks things.
    # It is very important that we see the last movment command...
    # Could possibly be simpler, but it seems to work.

    # Come up with a reasonable delay time...
    set (delay) 10
    
    proc windowSize { args } {
      variable {}
      # putx "windowSize $args"
       # startProc "Start windowSize "
      if {[info exists (windowSizeId)]} {
	# puts "#"
	after cancel $(windowSizeId)
      }
      incr (windowSizeActive)
      
      # if {[info exists ::glob(asyncCount)]} {
      # 	#set delay 1000
      # 	if {[info exist ::glob(init_done)] && $::glob(init_done) == 1} {
      # 	  set delay 10
      # 	}
      # }
      # # putx "-"
      set (windowSizeId) [after $(delay)\
			      [namespace code [list windowSize_ $(windowSizeActive)]]]
    }
    proc windowSize_ {count} { 
      variable {}
      if {[wm state .] == "withdrawn"} {
	windowSize defer
	return
      }
       # startProc "Start windowSize_ $count "
      # putx "windowSize_ $(windowSizeActive) $count $(windowSizeNow)"
      if {$(windowSizeActive) > $count || $(windowSizeNow)} { 
#	frputs (baseWindow) count (windowSizeActive)
	set (windowSizeTossed) $count
	# puts "windowSize_ Exit (tossed)"
	return
      }
      set (windowSizeNow) $count
      upvar #0 $(order) listboxlist
#     frputs (baseWindow) count (windowSizeActive)
      # First set the scroll width to match the required width
      set (win) ""
      stop 
      set h1 [winfo height $(baseWindow).top]
      set hr [expr {($h1 - $(fixHeight)) / $(lnspace)}]
 #    frputs (lnspace) h1 hr
      foreachBut "-." {
	upvar hr hr
	$wc.$win configure -height $hr
      }
      set (windowSizeNow) 0
      # The following little dance is to get the column scroll bar
      # to conform to the requested width (heigth) 
      # This is a problem in windows for some unknown reason
      grid columnconfigure $(baseWindow).top.c all -pad 1
      update idletasks
      grid columnconfigure $(baseWindow).top.c all -pad 0
      # If we tossed one larger than what we just did, schedule another
      if {$(windowSizeTossed) > $count} {
	windowSize $count
#	frputs (baseWindow) (windowSizeActive)
      }
      #       frputs (baseWindow) (windowSizeActive)
       # startProc "End windowSize_ "
       # putx "windowSize_ Exit (done)"
    }
    # -----------------
    # the resize procs
    # -----------------
    # start resizing
    proc start {w x} {
      # putx "start"
      variable {}
      lassign [winfo pointerxy .] xx yy
      # use regexp to get the final part of the window name..
 #     frputs w
      if { ! [regexp {.*\.label([^.]*$)} \
		  [winfo containing -displayof $w \
		       [expr {$xx - $(chwidth)}] $yy] \
	       match (win)]}  return
 #     frputs (win)
      set (xx:cent) $x
      #	  frputs (win) x
      set (started) [winfo width $w.$(win)]
      set (lwidth) 0
      return
    }
    # stop resizing
    proc stop { } {
       # putx "stop"
      variable {}
      upvar #0 $(order) listboxlist
      set (started) 0
      if { ! [info exists (lwidth)] || !$(lwidth) } {
	set (win) "-."
      }
      set j 0
      while { $j < $(nocol) && [incr failsafe] < 100} {
	set tl [lindex $listboxlist $j]
	if { "[lindex $tl 0]" == $(win) } {
	  set listboxlist [lreplace $listboxlist $j $j \
			       [lreplace $tl 1 1 $(lwidth)]]
	}
	incr totalWidth [lindex $listboxlist $j 1]
	incr j
      }
      if {$failsafe > 95} {
	puts "multilistbox stop failsafe"
      }
      set totalWidth [expr {($totalWidth + 2) * $(chwidth)  }]
      set wt $(baseWindow).top
      $wt.ca configure -scrollregion [list 0 0 $totalWidth 1000]
 #     frputs totalWidth
      # update idletasks
#      frputs listboxlist j (win) tl
    }
    # resize
    proc resize {w x} {
      # putx "resize"
      variable {}
      upvar #0 $(order) listboxlist
      if {!$(started) || $(resizing)} { return }
      set (resizing) 1
      set ww 0
      # Compute requested width
      set (lwidth) [expr {($(started) + $x - $(xx:cent))}]
      # round up to chars
      set (lwidth) [expr {($(lwidth) + $(chwidth) - 1) / $(chwidth)}]
      # Keep min width to 2 (1 for label) else label would be 0 width
      set (lwidth) [expr {$(lwidth) < $(minCWidth) ? $(minCWidth):$(lwidth)}]
      # which reverts to text width
      $w.$(win) config -width $(lwidth)
      $w.label$(win) config -width [expr {$(lwidth) - 1}]
 #     update idletasks
      set (resizing) 0
    }
    # -----------------
    # Reorder columns...
    # -----------------
    # reorder start
    proc reorderstart { w col wc x}  {
      variable {}
      lassign [winfo pointerxy .] xx (yy)
      set (xx:start) $x
      # putx "restart $w"
      $w configure -cursor sb_h_double_arrow -state active
      return
    }
    # reorder stop
    proc reorderstop { w col wc x}  {
      variable {}
      upvar #0 $(order) listboxlist
      stop
      if {! [info exists (yy)] } {
	# if we are not reordering, possible we are sizeing...
	return
      }
      lassign [winfo pointerxy .] xx y
      set win [winfo containing -displayof $wc $xx $(yy)]
      set win2 [winfo containing -displayof \
		    $wc [expr {$xx -$(chwidth)}] $(yy)]
 #     frputs w wc win win2
      if {[string length $win2] > [string length $win] } {
	set win $win2
      }
      # Ok we have the starting window 'w' and the ending window 'win'.
      # figure out what to do... There are two slight problems.  If the
      # stop is outside of the window (left or right) 'win' will be ""
      # It may also be possible that 'win' is something else.  In any
      # case if the prefix is different it is  outside the window.  
      # If 'x' is >0 it is on the right, else, it is on the left.

      $w configure -cursor arrow -state normal

      if { $win == $w } return
      if { [file rootname $w] != [file rootname $win] } {
	if { $x > 0 } {
	  set d $(nocol)
	} else {
	  set d -1
	}
      } else {
	set win [file extension $win]
	set d 0
	while { $d < $(nocol) && [incr failsafe] < 100} {
	  if {".label[lindex $listboxlist $d 0]" == $win }  break
	  incr d
	}
	if {$failsafe > 95} {
	  puts "reorderstop failsafe 1"
	}
      }
      set i 0
      while {$i <= $(nocol) && [incr failsafe2] < 100} {
	if {[lindex $listboxlist $i 0] == $col} break
	incr i
      }
      if {$failsafe2 > 95} {
	puts "reorderstop failsafe 2"
      }
 #     frputs i d x win
      if { $x < 0 } {
	incr d
	if { $d == $i } return
      } else {
	if { $i == ($d -1) } return
      }
      set listboxlist [linsert $listboxlist $d [lindex $listboxlist $i]]
      if { $x < 0 } {incr i}
      set listboxlist [lreplace $listboxlist $i $i]
      unset (yy)
      reGrid
    }
    # changing the font requires redoing the grid as well as telling 
    # all the widgets about the new font.  We are exporting this.
    proc newFont { font } {
      variable {}
      upvar #0 $(order) listboxlist
      set wc $(baseWindow).top.c
      set (chwidth) [font measure $font 0]
      if {$(listColumnScroll)} {
	set (minsWidth) [winfo reqwidth $wc.hscroll[lindex $listboxlist 1 0]]
      }
      set (minWidth) [expr {( $(chwidth) * 2) > $(minsWidth) ? \
				($(chwidth) * 2) : $(minsWidth)}] 
      set (minCWidth) [expr {($(minWidth) + $(chwidth) - 1) / $(chwidth)}]
 #	puts " is $(minsWidth) after minwidth is $cwidth"
      # Propgate the new font and make sure the new sizes are understood
      # by all the windows.  Here is where we make sure we aren't trying
      # to build windows that are too small... 
      foreach listbox $listboxlist {
	lassign $listbox w width title
	$wc.label$w configure -font $font
	$wc.$w configure -font $font
	if { $width < $(minCWidth) } {
	  # putx "adjusting width from $width to $cwidth"
	  set width $(minCWidth)
	}
	$wc.$w config -width $width
	$wc.label$w config -width [expr {$width -1}]
	lappend newlistbox [list $w $width $title]
      }
      set listboxlist $newlistbox
      # Measure the used height
      set lw [listbox  .test  -font $font -height 1 -width 0]
      set h1 [winfo reqheight $lw]
      $lw config -height 2
      set h2 [winfo reqheight $lw]
      destroy $lw

      set (lnspace) [expr {$h2 -$h1}]
#     frputs (lnspace) h1 h2
      reGrid
    }
#    proc newWidths { } {
#      variable {}
#      uppvar #0 $(order) listboxlist
#      set wc $(baseWindow).top.c
#      foreach box listboxlist {
#	lassign  $listbox w width title
#	set width [expr {$width < $(minCWidth) ? $(minCWidth) : $width} ]
#	$wc.$w config -width $width
#	$wc.label$w config -width [expr {$width -1}]
#	lappend newlistbox [list $w $width $title]
#      }
#      set listboxlist $newlistbox
#      set (lwidth) 0
#      stop 
#      reGrid
#    }      
    proc foreachBut {except script } {
      variable {}
      upvar #0 $(order) listboxlist
      set return 0
      set wc $(baseWindow).top.c
      foreach listbox $listboxlist {
	lassign $listbox win width title
	if {$except != $win } {
	  # # putx "$wc $win $script"
	  eval $script
	}
      }
#      update idletasks
      return $return
    }
  }
  return [namespace eval $w:multilist "do_multilist $w  $listboxes $args"]
}
proc foreachListbox { w script } {
  return [foreachButListbox $w $script "-."]
}
#proc setNewListBoxWidths { wi } {
#  regsub {(\.top\.c$)} $wi {} w
#  return [namespace eval $w:multilist newWidths]
#}
proc foreachButListbox {wi script except } {
  # we get the 'w' returned by multilist.  Here we want just the first 
  # bit of it.  It looks like .----.top.c
  regsub {(\.top\.c$)} $wi {} w
  return [namespace eval $w:multilist foreachBut $except $script]
}
proc setListBoxFont {wi font} {
  regsub {(\.top\.c$)} $wi {} w
  namespace eval $w:multilist newFont "$font"
}
proc propagateSelection {wi} {
  regexp {(^.*)\.top\.c\.([^.]+$)} $wi foo w wf
  namespace eval $w:multilist synchro $wf
}
