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) -customdragsource true

  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 -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 -button 3 -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
}