#!/usr/local/bin/wish -f
#!./wish -f
# tv, version 2 -- requires tk2.1
# $Id: tv,v 1.7 1992/05/15 21:34:46 schwartz Exp schwartz $

set tmp1 "/tmp/twin1"
set tmp2 "/tmp/twin2"

proc seq_len {fn} {
  set n 0
  set f [open $fn "r"]
  while {[gets $f line] >= 0} { 
	if [regexp {^[A-Za-z]} $line] { incr n [string length $line] }
  }
  close $f
  return $n
}

if "$argc < 1" {error "Usage: tv seqfile"}

	# extent of sequence data
set seq_file [lindex $argv 0]
set seq_min 1
set seq_max [seq_len ${seq_file}]
	
	# scale factor, fixedpoint, y coord
set seq_scale 1
set seq_fixedpoint 100
set seq_height 1

	# map tag number to interval 
set tag2interval("") ""

	# map from my tag to twin's tag
set intervals_twinof("") ""

# Construct widgets...
# ...a frame with some controls,
frame .cmd 
button .cmd.help -text "help" -command "do_help"
button .cmd.init -text "init" -command "do_init"
button .cmd.twins -text "twins" -command "do_twins"
button .cmd.freeze -text "accept" -command "do_freeze"
button .cmd.cleanup -text "discard" -command "do_cleanup"
button .cmd.exit -text "exit" -command "do_exit"
pack append .cmd .cmd.help left
pack append .cmd .cmd.init left
pack append .cmd .cmd.twins left
pack append .cmd .cmd.freeze left
pack append .cmd .cmd.cleanup left
pack append .cmd .cmd.exit left
pack append . .cmd {fill expand}

# ...a place for data,
frame .data
set data [canvas .data.data -relief sunken -width 500 -height 100]
pack append .data .data.data {bottom expand fill}
pack append . .data {expand fill}

# ...a place for messages.
label .msg -text "message"
pack append . .msg {expand fill}

$data bind all <1> { do_select sel1 [screen2world %x] }
$data bind all <3> { do_select sel2 [screen2world %x] }
$data bind sel1 <1> { do_unselect sel1 [screen2world %x] }
$data bind sel2 <3> { do_unselect sel2 [screen2world %x] }

# Sort list of tuples.  We can't use builtin sort because that does
#   alphabetic comparisons, rather than numeric.
proc tuple_sort {tlist} {
  # XXX -- for now, just pipe to sort in output
  return $tlist
}

proc tuple_from_id {id} {
  global tag2interval
  return $tag2interval($id); 
}

proc tuples_from_ids {idlist} {
  global tag2interval
  set tlist ""
  foreach id $idlist { lappend tlist $tag2interval($id) }
  return [tuple_sort $tlist]
}

proc tuples_from_tag {tag} {
  global data
  return [tuples_from_ids [$data find withtag $tag]]
}

proc interval_lt {i j} {
  scan $i "%d %d" a b
  scan $j "%d %d" c d
  return [expr "$a < $c"];
}

proc last_before {x} {
  global data
  set int "$x $x"
  set before {}
  #puts stdout "last before $x"
  foreach id [$data find withtag frozen] {
    set item [tuple_from_id $id]
    #puts stdout "    item $item"
    if {[interval_lt $item $int]} { lappend before "$item" }
  }
  set max "0 0"
  foreach item $before {
    if {[interval_lt $max $item]} { set max "$item" }
    #puts stdout "    max $max"
  }
  return [lindex $max 1]
}

proc first_after {x} {
  global data seq_max
  #puts stdout "first after $x"
  set int "$x $x"
  set after {}
  foreach id [$data find withtag frozen] {
    set item [tuple_from_id $id]
    if {[interval_lt $int $item]} { lappend after "$item" }
  }
  set x [expr "$seq_max + 1"]
  set min "$x $x"
  foreach item $after {
    if {[interval_lt $item $min]} { set min "$item" }
  }
  #puts stdout "    min $min"
  return [lindex $min 0]
}

# Compute the list of ids that overlap the given one, excluding the baseline.
proc find_below {item} {
    global data tag2interval seq_height

    scan $tag2interval($item) "%d %d" a b
    #puts stdout "below = $data find overlapping $a $seq_height $b $seq_height"
    set below [$data find overlapping \
		[world2screen $a] $seq_height [world2screen $b] $seq_height]
    #puts stdout "for $item ($a $b) below is $below : [$data gettags $below]"

    # omit baseline and self
    if {[set i [lsearch $below $item]] > -1} \
        {set below [lreplace $below $i $i]}
    if {[set i [lsearch $below [$data find withtag baseline]]] > -1} \
        {set below [lreplace $below $i $i]}

    #puts stdout "prune to $below"
    return $below
}

# Answer if the given ids overlap the same interval(s).
proc overlap_same {idlist} {
  set same 1
  set prev ""
  foreach item $idlist {
    set below [lsort [find_below $item]]
    if {$below == "" || ($prev != "" && $prev != $below)} { set same 0 }
    set prev $below
  }
  return $same
}

# Accept new data, and add it to the (ordered) frozen list.
proc do_freeze {} {
  global data seq_height tag2interval
  set tenative [$data find withtag tenative]

  # Turn all tenative data into frozen data, and color it blue.
  foreach item $tenative {
    $data dtag $item tenative
    $data addtag frozen withtag $item
    $data itemconfigure $item -fill [color_for [$data gettags $item]]
  }

  # If both new intervals are in the same original one, then we don't
  # flush the other twin.  Find out if they are the same...  XXX
  set same [overlap_same $tenative]
  #puts stdout "$tenative -> $same"

  set a [set b [set c [set d 0]]]

  # If a new interval overlaps an old one and is at least 3/4 the 
  # size of the original, then keep the original.
  foreach item $tenative {
    set below [find_below $item]

    if {$below == ""} {
      # fine, just use new interval
      #puts stdout "nothing below, use new interval"
    } else {
      # XXX - why more than one?
      foreach thing $below {
        scan "$tag2interval($thing)" "%d %d" c d
        if {4*($b-$a) > 3*($d-$c)} {
          # forget new one
          #puts stdout "big enough, delete new interval"
          $data delete $item        
        } else {
          # use new one
          #puts stdout "small enough, delete below"
          $data delete $thing
        }
      }
    }
  }
}

# Write segments marked as selected to each of two files.
proc write_selected {tmp1 tmp2} {
  global data
  set f [open "|sort -n -o ${tmp1}" "w"]
    foreach tuple [tuples_from_ids [$data find withtag sel1]] {puts $f $tuple}
  close $f
  set f [open "|sort -n -o ${tmp2}" "w"]
    foreach tuple [tuples_from_ids [$data find withtag sel2]] {puts $f $tuple}
  close $f
}

# Create a line in the data area and return its id.
proc add_line {a b c} { 
  global data seq_height tag2interval
  set aa [world2screen $a]
  set bb [world2screen [expr "$b + 1"]]
  set tt [$data create line $aa $seq_height $bb $seq_height -width 15 -fill $c]
  set tag2interval($tt) "$a $b"
  return $tt
}

# Write out selected data and return the result from twins.
proc get_twins {} {
  global seq_file tmp1 tmp2
  write_selected ${tmp1} ${tmp2}
  set f [open "|twins ${seq_file} ${tmp1} ${tmp2}" "r"]
    flush_intervals
    gets $f line
  close $f
  return $line
}

# Run twins on selected data, and add the result to our data structures.
proc do_twins {} {
  global data intervals_twinof
  message "Computing..."; update
  set a [set b [set c [set d 0]]]
  # twins returns: score left right left right
  scan [get_twins] "%d %d %d %d %d" score a b c d
  message "Score is $score <$a $b> <$c $d>"

  set t1 [add_line $a $b red]
  set t2 [add_line $c $d red]

  set intervals_twinof($t1) $t2
  set intervals_twinof($t2) $t1

  $data addtag tenative withtag $t1
  $data addtag tenative withtag $t2
}


proc color_for {tags} {
  # Anything can be tagged as selected.
  if {[lsearch $tags sel1] > -1 || [lsearch $tags sel2] > -1} {return "green"} 
  # These are mutually exclusive, I think.
  if {[lsearch $tags gap] > -1} { return "yellow" } 
  if {[lsearch $tags tenative] > -1} { return "red" } 
  if {[lsearch $tags baseline] > -1} { return "black" } 
  if {[lsearch $tags frozen] > -1}   { return "blue" } 
  puts stderr "Unknown tag set: $tags"
  return "blue"
}

# Delete any intervals marked as tenative, and unselect selected ones.
proc flush_intervals {} {
  global data
  foreach tag {sel1 sel2} {
    foreach item [$data find withtag $tag] { 
      $data dtag $item $tag 
      $data itemconfigure $item -fill [color_for [$data gettags $item]]
    }
  }
  foreach item [$data find withtag tenative] { $data delete $item }
  foreach item [$data find withtag gap] { $data delete $item }
}

proc do_unselect {n x} {
  global data
  $data dtag current $n
  $data itemconfig current -fill [color_for [$data gettags current]]
  message "Unselect [tuples_from_tag current] in $n"
}

proc do_select {n x} {
  global data
  $data addtag $n withtag current
  $data itemconfig current -fill [color_for [$data gettags current]]
  message "Select [tuples_from_tag current] in $n"
}

# Coordinate transformations.  We use these because tk's canvas widget
#  only does per item transformations.

proc world2screen {x} {
    global seq_min seq_scale seq_fixedpoint
    return [expr "($x - ${seq_min}) * ${seq_scale} / ${seq_fixedpoint}" ]
}

proc screen2world {x} {
    global seq_min seq_scale seq_fixedpoint
    return [expr "($x * ${seq_fixedpoint} / ${seq_scale}) + ${seq_min} "]
}

# Misc.

proc message {m} { .msg configure -text $m }
proc do_help {} { message "Mischief needs idle hands." }
proc do_exit {} { puts stdout "bye";  destroy . }
proc do_cleanup {} { flush_intervals; message ""; update }
proc do_init {} { init_canvas; update }

proc toggle_gap {s x} {
  global data
  #puts stdout "$s - $x"
  if {[lsearch [$data gettag current] $s] > -1} {
    #puts stdout "$s in $tags"
    $data dtag current $s
    message "Remove gap from $s"
  } else {
    #puts stdout "$s not in $tags"
    $data addtag $s withtag current
    message "Add gap to $s"
  }
  set len [llength [$data gettag current]]
  if {$len == 2} { $data delete current ; message "Unselect gap" } \
  else {if {$len < 2} { error "can't happen" }}
}

proc select_gap {s x} {
  global data
  set a [expr "[last_before $x] + 1"]
  set b [expr "[first_after $x] - 1"]
  #puts stdout "$s : $a $b"
  set tag [add_line $a $b yellow]
  $data addtag $s withtag $tag
  $data addtag gap withtag $tag
  $data bind $tag <1> { toggle_gap sel1 0 }
  $data bind $tag <3> { toggle_gap sel2 0 }
  message "Selected gap <$a $b> in $s"
}

proc init_canvas {} {
  global seq_scale seq_height seq_min seq_max seq_fixedpoint data
  after 1000
  update
  $data delete all
  set seq_width [winfo width $data]
  set seq_height [expr [winfo height $data]/2]
  set seq_scale [expr \
        "(${seq_fixedpoint}*${seq_width})/(${seq_max}-${seq_min}+1)" ]
  set tag [add_line $seq_min $seq_max black]
  $data addtag baseline withtag $tag
  $data bind $tag <1> { select_gap sel1 [screen2world %x] }
  $data bind $tag <3> { select_gap sel2 [screen2world %x] }
}

init_canvas