''[JMeh] 20 Dec 2017'' - tblNaturalDrag

Implementation of a natural way of local drag and drop with automatic scrolling if the mouse cursor is above the first or last row in the tablelist or tablelist_tile widget, no matter which selection mode is active. All previous selected lines are collected into one block and inserted at the drop position. No mouse movement is required while scrolling, instead the speed of scrolling accelerates the longer the mouse cursor lingers over the first or last line. The actual drop position is shown by a horizontal line using the tablelist showtargetmark mechanism. At the end of the drag process a virtual <<Drop>> event is generated.

======tcl
package provide tblNaturalDrag 0.1


##
# @brief this installs the natural local drag & drop mechanism for the tablelist widget
# @param tbl tablelist widget
# @param args options: -button, -cycle, -accel, -color
#
# Install the natural local drag & drop mechanism for the tablelist or tablelist_tile 
# widget and configure it with the following options:
# - button specifies the button number (defaults to 1)
# - cycle specifies the time in milliseconds (defaults to 100) for calling the scroll procedure
# - accel sets the factor for acceleration (defaults to 1.0)
# - color sets the color of the target mark (defaults to green)
#
proc tblNaturalDrag {tbl args} {
  global dragInfo

  if {[info commands tablelist::tablelist] == {}} {
    error "package tablelist or tablelist_tile required"
  }
  
  # init configurable drag infos
  set dragInfo(button) 1
  set dragInfo(cycle) 100
  set dragInfo(accel) 1.0
  set dragInfo(color) green

  # set drag parameters
  foreach {opt val} $args {
    set item [string range $opt 1 end]
    if {[info exists dragInfo($item)]} {
      set dragInfo($item) $val
    } else {
      error "unknown option: $opt"
    }
  }
  
  $tbl configure -targetcolor $dragInfo(color)

  set dragInfo(start) 0
  set dragInfo(x) -1
  set dragInfo(y) -1
  set dragInfo(timer) {}

  # start with mouse button down event
  bind [$tbl bodytag] <ButtonPress-$dragInfo(button)> {_tblNaturalDragStart %W %x %y}
}


proc _tblNaturalDragStart {w x y} {
  global dragInfo

  # make window coordinates listbox relative
  foreach {tbl x y} [tablelist::convEventFields $w $x $y] {}
  # setup dragInfo array
  set dragInfo(start) [clock milliseconds]
  set dragInfo(x) $x
  set dragInfo(y) $y
  set dragInfo(row) -1
  # start check timer for scrolling
  set dragInfo(timer) [after $dragInfo(cycle) _tblNaturalDragCheck $tbl]
  # update coordinates on mouse movement
  bind [$tbl bodytag] <Motion> {_tblNaturalDragScan %W %x %y}
  # end with release of mouse button
  bind [$tbl bodytag] <ButtonRelease-$dragInfo(button)> {_tblNaturalDragDrop %W %x %y}
}


proc _tblNaturalDragCheck {tbl} {
  global dragInfo

  after cancel $dragInfo(timer)
  set x $dragInfo(x)
  set y $dragInfo(y)
  set dragInfo(row) [$tbl containing $y]
  $tbl showtargetmark before $dragInfo(row)
  set topRow [$tbl index top]
  set botRow [$tbl index bottom]
  # calc scroll amount per time slot
  set now [clock milliseconds]
  set scrollCount [expr {int($dragInfo(accel) * ($now - $dragInfo(start)) / 1000.0 + 0.5)}]
  if {$dragInfo(row) == $topRow} {
    # scroll back n lines
    $tbl yview scroll -$scrollCount units
  } elseif {$dragInfo(row) == $botRow} {
    # scroll forward n lines
    $tbl yview scroll +$scrollCount units
  } else {
    # slow down if not in first or last row
    set dragInfo(start) $now
  }
  set dragInfo(timer) [after $dragInfo(cycle) _tblNaturalDragCheck $tbl]
}


proc _tblNaturalDragScan {w x y} {
  global dragInfo

  # make window coordinates listbox relative
  foreach {tbl x y} [tablelist::convEventFields $w $x $y] {}
  # update mouse coordinates
  set dragInfo(x) $x
  set dragInfo(y) $y
}


proc _tblNaturalDragDrop {w x y} {
  global dragInfo

  # stop scrolling immediately
  after cancel $dragInfo(timer)
  # make window coordinates listbox relative
  foreach {tbl x y} [tablelist::convEventFields $w $x $y] {}
  # remove mouse motion binding
  bind [$tbl bodytag] <Motion> {}
  # hide drop marker line
  $tbl hidetargetmark
  # quit if no drop destination 
  if {$dragInfo(row) == -1} return
  # get lines to move and quit if empty
  set sel [$tbl curselection]
  if {$sel == {}} return
  # count number of lines above drop line
  set upCnt 0
  foreach row $sel {
    if {$row < $dragInfo(row)} { incr upCnt } break
  }
  # get selected rows
  set selData [$tbl get $sel]
  set selCnt [llength $sel]
  $tbl delete $sel
  # calculate destination range
  set insRow [expr {$dragInfo(row) - $upCnt}]
  set lastRow [expr {$insRow + $selCnt -1}]
  # reinsert data at this new position
  if {$selCnt > 1} {
    $tbl insertlist $insRow $selData
  } else {
    $tbl insert $insRow $selData
  }
  # reselect inserted rows
  $tbl selection set $insRow $lastRow
  $tbl activate $insRow
  
  if {$insRow == $lastRow} {
    event generate $tbl <<Drag>> -data $insRow
  } else {
    event generate $tbl <<Drag>> -data [list $insRow $lastRow]
  }
}


if {[info exists argv0] && [file tail $argv0] == "tblNaturalDrag.tcl"} {
  package require tablelist_tile
  set tbl .t
  set cols {
    0 Name left
    0 Value right
  }
  grid [tablelist::tablelist $tbl -columns $cols -height 20 \
    -selectmode extended -autoscan false -customdragsource true \
    -yscrollcommand ".sby set"] -row 1 -column 0 -sticky nswe
  grid [ttk::scrollbar .sby -orient vertical -command "$tbl yview"] \
    -row 1 -column 1 -sticky ns
  grid rowconfigure . 1 -weight 1
  
  tblNaturalDrag $tbl -cycle 50 -accel 2.5
  proc dropDebugger {args} {puts "dropDebugger $args"}
  bind $tbl <<Drag>> {dropDebugger %W %d}
  
  set data {}
  set n 1000
  for {set i 0} {$i < $n} {incr i} {
    lappend data [list "Test $i" $i]
  }
  $tbl insertlist end $data
}
======